perm filename SOPU.PAS[S1,ALS]1 blob
sn#465804 filedate 1979-08-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00073 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00013 00002 (*PROGRAM HEADER PAGE*)
C00017 00003 program SOPAIPILLA (INPUT*,OUTPUT,PRR) (*X10S1*)
C00019 00004 (* Compiler-option constants... *)
C00028 00005 (* Constants fixed by S1 architecture... *)
C00035 00006 type
C00065 00007 var
C00077 00008 (** ERROR_CLASS: ERREXIT ASSERTFAIL ERROR **)
C00098 00009 (** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTMTYP PRINTINT **)
C00113 00010 (** SETREP_PROCESSOR_CLASS: SET_IN SET_DIF SET_INT SET_UNI BUILD_SET *)(*setch*)
C00118 00011 (** S1WORD_PROCESSOR_CLASS: NEWCODEREC GETFIELD GETSIGNEDFIELD PUTFIELD **)
C00125 00012 (** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
C00135 00013 (** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVCHR_S1WORD_4 CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
C00143 00014 (** INSTRUCTION_PROCESSOR_CLASS:PTR_OPNDXWD S1OPNDS_EQUAL S1OPND_TEMPLOC GETS1OPCODE AFTER_LAST_XWORD JUMPSKIPDEST NEXT_INSTRUCTION AFTER_FAKEOPS AFTER_NONS1LOC_FAKEOPS INVERT_SKIP INVERT_OPCODE **)
C00156 00015 (** INSTRUCTION_PROCESSOR_CLASS:DELETE_INSTR INSERT_OPND1 PEEP_LOC_IS_FREE SWAP_OPERANDS INSTR_WORDS PRINTMAINCODE **)
C00171 00016 (** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 **)
C00176 00017 (** FIXUP_CLASS: ADD_CODEPTR_TO_CODELIST ADD_JUMPLIST_PLUS_ONE ADD_JUMP_TO_JUMPLIST JUMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
C00182 00018 (** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_REG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
C00190 00019 (** OPERAND_PROCESSOR_CLASS: EXTENDED_IMM_OPERAND REGDISP_OPERAND EXTENDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND TWIDDLE_OPERAND **)
C00197 00020 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLAREFREE ALLOCRG ALLOCRP FREERG_S FINDRGBLOCK FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
C00210 00021 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREEVPARGUNLESS FREE_TEMP_REGS **)
C00218 00022 (** CODE_EMITTER_CLASS: BUILD_CW_OPERAND EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
C00226 00023 (** CODE_EMITTER_CLASS: EMITFAKEINST INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
C00233 00024 (** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
C00242 00025 (** DATUM_PROCESSOR_CLASS: LENGTH_TO_INTOPNDTYPE REG_DATUM COERCE_DATUM CVT_INT_DATUM COERCE_INT_DATUM COERCE_TWO_DATUMS DATUM_IS_REG DATUM_ISFREE_REG DATUM_IS_T_REG DATUM_IS_FILADR LOADSTKENTRY LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM XCHANGE_STKENTS **)
C00267 00026 (** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE INC_INDIRECTION TRANSLATE_LVLDSP **)
C00275 00027 (** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CONST_PLUS_OPND PUSHTOP POPTOP PUSH_STKFRAME POP_STKFRAME **)
C00281 00028 (** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
C00286 00029 (** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
C00290 00030 (** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
C00300 00031 (** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
C00305 00032 (** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
C00308 00033 (** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
C00315 00034 (** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
C00348 00035 (** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXWRD1 PRINTXWRD2 PRINTOPERAND PRINTREG PRINT_SIGNED_OCTAL PRINTSHORTOP **)
C00366 00036 (** OBJECT_MODULE_SEGMENT_CLASS: CODE_CONCRETIZER CONC_PASS1 INSERT_S1LOC JMPX_TO_JMPA_OPT **)
C00375 00037 (** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER SKIP_JMPA_OPT COLLAPSE_MOV_OPT **)
C00386 00038 (** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER **)
C00392 00039 (** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS3 PASS3PCRELFIX INSERT_NOP **)
C00405 00040 (** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
C00414 00041 (** OBJECT_MODULE_SEGMENT_CLASS: OPEN_SEG CLOSE_SEG OUT_SEG OPEN_ESD CLOSE_ESD OUT_ESD OPEN_ESR CLOSE_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
C00422 00042 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00430 00043 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00437 00044 (** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
C00459 00045 (*** ASSEMBLE_NEXT_INSTRUCTION_CLASS: ASMNXTINST ***)
C00465 00046 (*** ANI_CLASS: ARITH_1_OPS UABS UNEG UADD UINC UDEC ***)
C00470 00047 (*** ANI_CLASS: ARITH_2_OPS USUB ***)
C00478 00048 (*** ANI_CLASS: ARITH_3_OPS UMPY USQR ***)
C00489 00049 (*** ANI_CLASS: ARITH_4_OPS UDIV UDMD UMOD ***)
C00496 00050 (*** ANI_CLASS: COMPARE_SETS REL_OPS UEQU UGEQ UGRT ULEQ ULES UNEQ UIEQU UIGEQ UIGRT UILEQ UILES UINEQ ***)
C00511 00051 (*** ANI_CLASS: BOOL_OPS UAND UIOR UXOR UNOT UODD ***)
C00517 00052 (*** ANI_CLASS: SET_OPS UDIF UINT UUNI UINN USGS UADJ UMUS ***)
C00526 00053 (*** ANI_CLASS: LOAD1_STORE_OPS ULCA ULDA ULDC ULOD ULDP UILOD UPLOD ***)
C00533 00054 (*** ANI_CLASS: LOAD2_STORE_OPS USTR UNSTR UISTR UINST UPSTR UMOV ***)
C00546 00055 (*** ANI_CLASS: FLOW_CONTROL_OPS UTJP UFJP UUJP UXJP UGOOB ULAB UCLAB ***)
C00556 00056 (*** ANI_CLASS: ENVIRONMENT_OPS UBGN UEND USTP UENT UBGNB UENDB ***)
C00563 00057 (*** ANI_CLASS: CHECK_OPS UCHKL UCHKH UCHKT UCHKF UCHKN ***)
C00568 00058 (*** ANI_CLASS: TYPE_CONV_OPS URND UTYP UTYP2 UCVT UCVT2 ***)
C00574 00059 (*** ANI_CLASS: VIRT_STK_OPS UDUP USWP UIXA ***)
C00583 00060 (*** ANI_CLASS: PROC_CALL_OPS UMST UPAR UCUP UICUP UCSP URET ***)
C00599 00061 (*** ANI_CLASS: IMP_EXP_OPS UIMPP UIMPV UEXPP UEXPV ***)
C00600 00062 (*** ANI_CLASS: COMP_TIME_OPS UCOMM UOPTN ULEX USYM ULIVE UDEAD UDOA UDEF UMDEF ULOC ***)
C00608 00063 (*** ANI_CLASS: ***)
C00612 00064 (** READNXTINST_CLASS: READNXTINST READNAM READTYP READMTYP READINT READREAL READSTRING READSET UUNK *)
C00625 00065 (** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
C00650 00066 (** INITIALIZE_CLASS: INIT2 **)
C00667 00067 (** INITIALIZE_CLASS: INIT3 **)
C00688 00068 (** INITIALIZE_CLASS: INIT4 **)
C00713 00069 (** INITIALIZE_CLASS: INIT5 **)
C00736 00070 (** INITIALIZE_CLASS: INIT6 **)
C00741 00071 (** INITIALIZE_CLASS: INIT7 **)
C00753 00072 (** INITIALIZE_CLASS: **)
C00754 00073 (** MAIN_PROGRAM: **)
C00760 ENDMK
C⊗;
(*PROGRAM HEADER PAGE*)
(*PAS10 OPTIONS*) (*$D+,R32,S1600*) (*X10S1*)
(* DEFAULT
D+ DEBUG AND POSTMORTEM DUMP -
E+ EXTERNAL CALLS TO LEVEL 1 PROCEDURES ALLOWED -
Fn FILE OPTION 1
I+ FORTRAN I/O IN EXTERNAL FORTRAN SUBROUTINES -
L+ OBJECT LISTING -
Rn SIZE OF LOW-SEGMENT (SEE PAS10 MANUAL)
Sn MAX INSTRUCTIONS PER STATEMENT 1000
T+ RUNTIME CHECK +
U+ 72 COLUMN FORMAT -
Xn HIGHEST REGISTER FOR PARAMETERS 6
*)
(*SLAC PCPASC OPTIONS*) (* B+,D+,M-*)
(* DEFAULT
A+ GENERATE 370 OBJECT MODULE -
A- GENERATE 370 ASSEMBLY MODULE
B+ BOUNDS CHECKING, BUT ALLOW 'BIG' CHARACTERS -
C+ EMIT PCODE +
D+ RUNTIME CHECKING OF POINTER, INDEX, SUBRANGE VALUES -
E+ FILE IS IN EBCDIC CHARACTER SET -
F+ SAVE FPR'S ON PROCEDURE/FUNCTION ENTRY +
K+ ENABLE STATEMENT EXECUTION COUNTING -
L+ LIST SOURCE PROGRAM +
M+ 72 COLUMN FORMAT +
P+ DOUBLE-WORD BOUNDARY ALIGNMENT -
S+ SAVE GPR'S ON PROCEDURE/FUNCTION ENTRY +
T+ PRINT SYMBOL TABLES (FOR POST-PROCESSOR) -
U+ GET STATISTICS?? 2ND PARAMETER TO PCODE BGN INSTR. -
V+ ?? 3RD PCODE BGN INSTRUCTION PARAMETER -
X+ USE ACTUAL PROCEDURE NAMES FOR EXTERNAL REFERENCES -
X- GENERATE UNIQUE 8-CHAR NAMES FOR EXTERNAL REFERENCES
*)
(*S1 PCPASC OPTION DIFFERENCES*) (* A+,B+,D+,M120*) (*X10S1*)
(* DEFAULT
A+ GENERATE S1 ASSEMBLY MODULE -
A- GENERATE S1 OBJECT MODULE
*)
(* PDP-10/S-1 TRANSPORT DEPENDENCIES FLAGGED WITH "X10S1" *)
(*SETCH MARKS CHANGES MADE TO ENLARGE SET SIZE*)
(*NOTE: TO TRANSPORT THIS PROGRAM TO THE S-1 WHEN THE HOST COMPILER HAS ONLY
TWO-WORD SETS, IT IS NECESSARY TO DO IT IN TWO STAGES. FIRST, MAKE ALL
"X10S1" CHANGES THAT ARE *NOT* MARKED "X10S1/FULL" AND PUT THAT VERSION
UP ON THE ACTUAL S-1. SECOND, MAKE ALL CHANGES MARKED "X10S1/FULL" AND
USE THE INTERMEDIATE VERSION TO COMPILE THE FULLY-TRANSPORTED VERSION.*)
program SOPAIPILLA (INPUT*,OUTPUT,PRR); (*X10S1*)
(*program SOPAIPILLA (INPUT,OUTPUT,PRR);*) (*X10S1*)
(*SOPAIPILLA - Stanford Optimizing Packed-Address Implementation of a
Ucode Intermediate Language Logical Assembler*)
(*CAVEAT : This is a preliminary version of this program. It should not
be considered in any sense in final form, since it is undergoing daily
development and modification.*)
(*This program translates P-Code, an intermediate language invented as a
target language of a PASCAL compiler, into S-1 machine language. During
the translation process, a number of local optimizations are performed. A
detailed description of the logic of the program, including discussion of
the optimizations performed is contained in the document SOPADOPE*)
(*SOPAIPILLA was written during summer 1977 by Erik J. Gilbert and David
W. Wall of the Computer Science Department at Stanford University. Much
of its internal philosophy is based on a similar compiler for the IBM 370
written by Sassan Hazeghi, also of the Stanford C.S. Dept.*)
(* Ucode Progress record
See list on page 6.
End of progress record *)
(* Compiler-option constants... *)
const
SOPA_ID = 'SOPU, version of 09AUG79 16:03';
CHARDIF = 0; (*setch*)
"CHARDIF = 40B;" (*CHARDIF*) (*X10S1*)
(*CHARDIF = 0; *) (*CHARDIF*) (*X10S1*)
(* LCW 2AUG78
This compiler will not compile programs containing constants outside the
range of MIN_ON_COMP_MACH..MAX_ON_COMP_MACH. Furthermore,
MAX_ON_COMP_MACH and MIN_ON_COMP_MACH must be set to the minimum and
maximum values, respectively, of integers of the machine on which this
compiler runs. BITS_ON_COMP_MACH must be set to the number of bits in
an integer of the machine on which the compiler runs. However, when
running the compiler on a machine with a word size larger than that of
the S1, these constants must be set as if that machine had a word size
equal to that of the S1. Never try to run this program on a machine with
word length less than 32.
*)
(*MAX_ON_COMP_MACH = 2147483647; " 2**31 - 1 (370) " *)
(*MIN_ON_COMP_MACH = -2147483648; " -2**31 (370) " *)
(*BITS_ON_COMP_MACH = 32; " 370 " *)
(*MAX_EXP_ON_COMP_MACH = 30; " two less than bits " *)
MAX_ON_COMP_MACH = 34359738367; " 2**35 - 1 (10/S1) "
MIN_ON_COMP_MACH = -34359738367; " -2**35 (10/S1) "
(* MIN_ON_COMP_MACH should be one less, but runtime won't accept it ... *)
BITS_ON_COMP_MACH = 36; " 10/S1 "
MAX_EXP_ON_COMP_MACH = 34; " two less than bits "
BLKMOV_THRESH = 225; (*PMOVs of >= 225 QWs generate BLKMOV*)
(*Everything < 225 QWs can be done with
at most 3 MOVMQs or 2 MOVMSs*)
MINPARS1REG = 8; (*smallest numbered parameter register*)
MAXDSPS1REG = 29; (*largest numbered display register*)
MAXPAREG = 10; (*Maximum number of parameter registers*)
MAXPAREGM1 = 9; (*Maximum logical index of a parameter reg*)
MINBLOCK = 1; (*Minimun legal number for a memory block*)
MAXBLOCK = 500; (*Maximum legal number for a memory block*)
ILLBLOCKNO = -1; (*Illegal block number for initialization*)
MAXLVL = 8; (*Maximum nesting of procedure declarations*)
MAXLBL = 99999; (*Maximum label integer*)
MAXCODEW = 999999; (*Maximum number of words in a CODEREC*)
ALFASIZE = 16; (*Maximum length of type ALFA*)
STRINGMAX = 150; (*Maximum length of a string, in characters*)
STRINGBITMAX = 1395; (*Maximum length of a string, in bits*)
SEG_START_RELPC = 0; (*Relative PC of segment start*)
SEG_EP_DISP = 16; (*Storage units from seg start to entry point*)
TMPDATAWORDSGUESS = 3;
SFLDMAX = 3; (*VPA shift maximum*)
NILVAL = -1;
MAXS1LOC = 16777215; (*2**24-1 - really should be = MAXS1ADDR, 2**30-1*)
S1LOCUNDEF = MAXS1LOC;
MAXPEEP_PASSES = 2; (*Maximum number of passes in PEEPHOLE_OPTIMIZER*) (*PTZ*)
MINSTKINX = -1;
MAXSTKINX = 30; (* peg 09jul79 -- may have to be increased.*)
TMPD1 = MINSTKINX; (*TMPD1 is used to hold synthetic DATUMs*)
MINFRAME = 1; (* peg 09jul79 *)
MAXFRAME = 15; (* peg 09jul79 *) (*Same as MAXMST*)
MAXMST = 15; (*Maximum nesting of function calls*)
MAXESDINDEX = 1000;
MAXESRINDEX = 1000;
MAXZINDEX = 1000; (*max of two above*)
LBLHTSIZE = 197; (*prime*)
LBLHTSIZEM1 = 196;
CSPHTSIZE = 91; (*prime*)
CSPHTSIZEM1 = 90;
OPCHTSIZE = 263; (* ALS 7/16/79*)
OPCHTSIZEM1 = 262;
(*OPCHTSIZE = 197;*) (*prime*)
(*OPCHTSIZEM1 = 196;*)
(*370 values for 4 constants ... *)
(*
LCAFTMST = 80;
FNCRSLT = 72;
LASTFILBUF = 280;
L1LOCALDATATRANSLATION = 408; "*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*"
*)
(*S1 valuesfor 4 constants ... *)
LCAFTMST = 8;
FNCRSLT = 0;
LASTFILBUF = 44; (*level 1 dsplmt of first local variable,
which is after level 1 MST part.*)
% L1LOCALDATATRANSLATION = 172; (*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*)\
% ↑ commented out: peg 27jul79 \
LCIOFILADR = 8; (*level 1 dspl of the global variable used
to store current I/O file addr*)
(* Address tranlation constants -- als/peg 18jul79...*)
FIRSTADDR = 0; (*Address (in qwords) of first local variable for
> L1 procedures = FNCRSLT*)
L1FIRSTADDR = 44; (*Address (in qwords) of first local variable for
L1 procedures = LASTFILBUF*)
OFFSET_IN_VARS = 128; (*Offset of display in local variable area =
-MINSHORTOFFSET*WORDUNITS *)
R_OFFSET = -172; (*Offset of RegParmSaveArea from display =
-REGIMAGEAREASIZE - OFFSET_IN_VARS*)
M_OFFSET = -128; (*Offset of beginning of M memory area from
display = -OFFSET_IN_VARS*)
DISPLAY_OFFSET = 172; (*Offset of display from beginning of segment, not
including the EvalSaveArea, for > L1 procedures*)
L1DISPLAY_OFFSET = 172; (*Offset of display from beginning of segment, not
including the EvalSaveArea, for L1 procedure*)
FILE_OFFSET = -172; (*Offset of file buffers from display =
-FILBUFAREASIZE - OFFSET_IN_VARS*)
REGIMAGEAREASIZE = 44; (*Size of Register Image Area, in quarterwords =
(MAXPAREG + 1)*WORDUNITS*)
FILBUFAREASIZE = 44; (*Size of File Buffer Area, in quarterwords =
LASTFILBUF*)
(*...Address tranlation constants -- als/peg 18jul79 *)
(* ...end compiler-option constants *)
(* Constants fixed by S1 architecture... *)
FIRSTS1REG = 0;
S1RCPL = 0; (*register to start CPL block-descriptor*)
S1R0 = 0;
S1RPC = 3;
S1RTA = 4;
S1RTB = 6;
S1RSP = 30; (*stack-pointer register*)
S1RNP = 31; (*heap-pointer register*)
LASTS1REG = 31;
S1RNPMEMADR = 124; (*memory address of S1RNP*) (*BNDTRPKLU*)
FIRSTS1GBL = 32; (*globals are low-core memory words*)
S1GMEMEND = 32; (*runtime sets up address of last QW of heap here*)
S1GSEGBASE = 33; (*global number of segment base for trace*)
S1GBLZ = 34; (*global number of zero word for block descriptor use*)
S1GCPLPL = 35; (*global number of CPLPL block-descriptor*)
LASTS1GBL = 39; (*number of last S1 low-core global*)
(*DO NOT assign globals beyond 47 (octal addr 276) without
also changing FSIM, PASRUN, and S1 DDT. - EJG 26JAN79 *)
MAXS1ADDR = 1073741823; (*2**30 - 1*) (*EJG*)
MINS1DISP = -16777216; (*-2**24*)
MAXS1DISP = 16777215; (*2**24 - 1*)
MINSIGNEDS1ADDR = -536870912; (*-2**29*)
MAXSIGNEDS1ADDR = 536870911; (*2**29-1*)
MINSHORTOFFSET = -32;
MAXSHORTOFFSET = 31;
MINSHORTCONSTANT = -32;
MAXSHORTCONSTANT = 31;
MAXINDEXSHIFT = 3;
MINJPROFFSET = -2048;
MAXJPROFFSET = 2047;
MINSKPOFFSET = -8;
MAXSKPOFFSET = 7;
MAXMOVMQ = 32; (*64 and 128 are handled specially*)
(*MAXMOVMQ must be a multiple of WORDUNITS*)
MAXMOVMS = 32; (*5DEC78 ALS*)
S1TRUEFLAG = -1;
DALIGNSHIFT = 3;
DALIGNMUL = 8;
CHARBITS = 9;
QWBITS = 9;
HWBITS = 18;
WORDBITS = 36;
DWBITS = 72; (* peg 09jul79 *)
WORDCHARS = 4;
QUARTERWORDUNITS = 1;
HALFWORDUNITS = 2;
WORDUNITS = 4;
DOUBLEWORDUNITS = 8;
PAGEUNITS = 2048;
MAXALIGNBOUNDARY = 4;
(*setch...*) (*X10S1/FULL...*)
SET_SIZE = 144; (*Number of set elements on the S1.*)
SET_MAX = 143; (*Max legal value of a set element on the S1.*)
HOST_SET_SIZE = 72; (*Number of set elements/set in host compiler.*)
HOST_SET_MAX = 71; (*Max legal value of a host set element.*)
SETREP_MAX = 1; (*Number of host sets used/set - 1.*)
S1SETREP_SIZE = 4; (*Number of S1 words used/set.*)
S1SETREP_MAX = 3; (*Number of S1 words used/set - 1.*)
NUMOFSETPARTS = 2; (*Number of double-word parts/set.*)
SETPART_MAX = 1; (*Number of double-word parts/set - 1.*)
NUMOFSETOPND = 9; (*Number of operands in PCode LDC S,(---) ins.*)
(*...setch*) (*...X10S1/FULL*)
"(*setch...*) (*X10S1/FULL...*)
SET_SIZE = 144; (*Number of set elements on the S1.*)
SET_MAX = 143; (*Max legal value of a set element on the S1.*)
HOST_SET_SIZE = 144; (*Number of set elements/set in host compiler.*)
HOST_SET_MAX = 143; (*Max legal value of a host set element.*)
S1SETREP_SIZE = 4; (*Number of S1 words used/set.*)
S1SETREP_MAX = 3; (*Number of S1 words used/set - 1.*)
NUMOFSETPARTS = 2; (*Number of double-word parts/set.*)
SETPART_MAX = 1; (*Number of double-word parts/set - 1.*)
NUMOFSETOPND = 9; (*Number of operands in PCode LDC S,(---) ins.*)
(*...setch*) (*...X10S1/FULL*)"
OPCODE_START = 0; OPCODE_LEN = 12;
OPND1_START = 12; OPND1_LEN = 12;
OPND2_START = 24; OPND2_LEN = 12;
T_START = 10; T_LEN = 2;
PR_START = 11; PR_LEN = 1;
SKP_START = 8; SKP_LEN = 4;
J_START = 24; J_LEN = 12;
FAKEOPND_START = 12; FAKEOPND_LEN = 24;
OPND_START = 0; OPND_LEN = 12; (*PTZ*)
OPNDX_START = 0; OPNDX_LEN = 1;
OPNDREG_START = 1; OPNDREG_LEN = 5;
OPNDF_START = 6; OPNDF_LEN = 6;
OPND1X_START = 12; OPND1X_LEN = 1;
OPND1REG_START = 13; OPND1REG_LEN = 5;
OPND1F_START = 18; OPND1F_LEN = 6;
OPND2X_START = 24; OPND2X_LEN = 1;
OPND2REG_START = 25; OPND2REG_LEN = 5;
OPND2F_START = 30; OPND2F_LEN = 6;
XWP_START = 0; XWP_LEN = 1;
XWV_START = 1; XWV_LEN = 1;
XWD_START = 2; XWD_LEN = 1;
XWI_START = 3; XWI_LEN = 1;
XWS_START = 4; XWS_LEN = 2;
XWADDR_START = 6; XWADDR_LEN = 30;
XWREG_START = 6; XWREG_LEN = 5;
XWDISP_START = 11; XWDISP_LEN = 25;
BNDTYP_START = 0; BNDTYP_LEN = 9;
RGS = 0; MEM = 1; (*should be enum. type, but alignment*)
(* ...end constants fixed by S1 architecture *)
type
ERRORCODE = (
WARITH_ON_WRONG_DT,
WNOT_IMPLEMENTED,
WILLEGAL_LABEL,
WABS_OR_NEG_OF_NONSIGNED,
WADDR_OUT_OF_RANGE,
WADDRESS_CHECK_ON_NONADDRESS,
WALIGNMENT_ERROR,
WANDOR_NEEDS_BOOLEAN,
WBGN_STP_NAME_MISMATCH,
WENT_AND_PLOD_INCONSISTENT,
WENT_END_NAME_MISMATCH,
WENT_SPECIFIED_WRONG_PARMS,
WBINARY_OPND_TYPE_CONFLICT,
WBOOL_IS_TRUE,
WBOOL_NOT_TRUE,
WCHECKED_CONSTANT_OUT_OF_RANGE,
WCHKF_CHKT_NEEDS_BOOLEAN,
WCHKN_NULL_TOP,
WCHKN_NOT_ADDRESS,
WCHECKING_INVALID_TYPE,
WCHR_NEEDS_INT,
WCOERCION_INVALID,
WCOMPARE_ILLEGAL,
WCOMPM_NEEDS_ADDR,
WCONST_OUT_OF_RANGE_FOR_SET,
WDISP_OUT_OF_RANGE,
WDUP_ON_EMPTY_STACK,
WEQU_etc_with_TYP_is_TYPM,
WEXPR_TOO_COMPLEX,
WFILE_ADDRESS_NEEDED,
WTJP_FJP_NEEDS_BOOLEAN,
WTJP_FJP_WITH_NONEMPTY_STACK,
WFIX_OF_INVALID_TYPE,
WFLOAT_OF_INVALID_TYPE,
WFUNC_CALLS_NESTED_TOO_DEEPLY,
WIEQU_etc_with_TYP_not_TYPM,
WILLEGAL_PROC_TYPECODE,
WINCOMPATIBLE_TYPES,
WINDEX_WITHOUT_BASE,
WINDEXING_IN_PARMS,
WINN_REQUIRES_SET_ON_TOP_OF_STACK,
WINSTR_TYPE_NOT_DATUM_TYPE,
WINSUFF_PARMS_SPECIFIED,
W2_MANY_PARMS_SPECIFIED,
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO,
WINVAL_BLOCK_NUMBER,
WINVAL_CSP,
WINVAL_OPC,
WINVAL_TRACE,
WINVAL_TYP_ON_LDC,
WINVAL_U_TYPECODE,
WINVALID_DISPLACEMENT,
WINVALID_TYPE_COERCION,
WINVALID_LEVEL,
WINVALID_MEMORY_TYPE,
WIXA_NEEDS_ADDR,
WL_LPTR_LBLNUM_UNDEFINED,
WLAST_SST_PARM_TOO_BIG,
WLOADING_STRING,
WISTR_INST_NEEDS_ADDRS,
WMOV_NEEDS_ADDRS,
WMST_SPECIFIED_INSUFF_PARM_STORAGE,
WMST_WITHOUT_CUP_IN_LAST_SEGMENT,
WMULT_DEFINED_LAB,
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX,
WNEW_MUST_HAVE_ADDR_AND_INT,
WNOT_AN_ADDR,
WNOT_DISCRETE_TYPE,
WNOT_NEEDS_BOOLEAN,
WNULLREF,
WODD_REQUIRES_AN_INTEGER,
WORD_NEEDS_INT_BOOLEAN_OR_CHAR,
WPOP_OF_EMPTY_STACK,
WREAL_CONSTANT_DIVISION_BY_ZERO,
WREGPARMS_SPEC_TOO_LOW_IN_MST,
WRST_NEEDS_ADDR,
WSAV_NEEDS_ADDR,
WSET_OPERATION_ON_NONSET_TYPES,
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN,
WSIO_DIDNT_SEE_FILEADDR,
WSIO_WITH_NONADDRESS,
WSQUARE_OF_INVALID_TYPE,
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT,
WSTACK_NON_EMPTY,
WSTACK_NOT_SINGLE,
WSWP_NOT_2,
WSWP_TYP_ERROR,
W2_MANY_BGNBS,
W2_MANY_ENDBS,
WTOO_LARGE_K_OR_L,
WTRUNCATE_OF_INVALID_TYPE,
WCVT_WITH_INVALID,
WTYP_WITH_INVALID,
WUJP_WITH_NONEMPTY_STACK,
WWRONG_INSTR_DATATYPE,
WWRONG_COMPARE,
WWRONG_RESULT_NUMBER,
WXJP_WITHOUT_SINGLETON_STACK);
(* Corrected list June 7, 1979*)
U_OPCODE = (
UABS ,UADD ,USUB ,UMPY ,UDIV ,UADJ ,UAND ,UBGN ,UBGNB,UCHKF,
UCHKH,UCHKL,UCHKN,UCHKT,UCLAB,UCOMM,UCSP ,UCUP ,UCVT ,UCVT2,
UDEAD,UDEC ,UDEF ,UDIF ,UDMD ,UDOA ,UDSP ,UDUP ,UEND ,UENDB,
UENT ,UEXPP,UEXPV,UFJP ,UICUP,
UGOOB,UMOV , (*UMOV added 30Jun79 by peg*)
UEQU ,UNEQ ,UGEQ ,UGRT ,ULEQ ,
ULES ,UIEQU,UINEQ,UIGEQ,UIGRT,UILEQ,UILES,UILOD,UIMPP,
UIMPV,UINC ,UINN ,UINST,UINT ,UIOR ,UISTR,UIXA ,ULAB ,ULCA ,
ULDA ,ULDC ,ULDP ,ULEX ,ULIVE,ULOC ,ULOD ,UMDEF,UMOD ,UMST ,
UMUS ,UNEG ,UNEW ,UNOT ,UNSTR,UODD ,UOPTN,UPAR ,UPLEX,UPLOD,
UPSTR,URET ,URND ,USDEF,USGS ,USQR ,USTP ,USTR ,USWP ,USYM ,
UTJP ,UTYP ,UTYP2,UUJP ,UUNI ,UUNK ,UXJP ,UXOR );
P_STANDARDPROC = (
QATN, QCLK, QCOS, QEIO, QELN, QEOF, QEXP, QGET, QLOG, QNEW,
QPUT, QRDB, QRDC, QRDI, QRDR, QRDS, QRES, QREW, QRLN, QRST,
QSAV, QSIN, QSIO, QSQT, QTRP, QWLN, QWRB, QWRC, QWRI, QWRR,
QWRS, QXIT);
S1OPCODE = (
XILLEGAL,
XPLOC,
XS1LOC,
XFREEREG, (*PBK*)
XABS_Q,
XABS_H,
XABS_S,
XABS_D,
XADD_S,
XADD_D,
XADJSP_UP,
XADJSP_DN,
XALLOC_1,
XAND_Q,
XAND_D,
XAND_TC_D,
XAND_CT_D,
XBLCMP_EQL_Q,
XBLCMP_NEQ_Q,
XBLCMP_GEQ_Q,
XBLCMP_GTR_Q,
XBLCMP_LEQ_Q,
XBLCMP_LSS_Q,
XBLKMOV,
XBTRP_B_Q,
XBTRP_B_H,
XBTRP_B_S,
XBTRP_B_D,
XBTRP_M1_Q,
XBTRP_M1_H,
XBTRP_M1_S,
XBTRP_M1_D,
XBTRP_0_Q,
XBTRP_0_H,
XBTRP_0_S,
XBTRP_0_D,
XBTRP_1_Q,
XBTRP_1_H,
XBTRP_1_S,
XBTRP_1_D,
XDEC_S,
XFX_DM_S_S,
XFX_DM_S_D,
XFX_FL_S_S,
XFLOAT_S_Q,
XFLOAT_S_H,
XFLOAT_S_S,
XFLOAT_S_D,
XFADD_S,
XFADD_D,
XFSUB_S,
XFSUBV_S,
XFSUB_D,
XFSUBV_D,
XFMULT_S,
XFMULT_D,
XFDIV_S,
XFDIVV_S,
XFDIV_D,
XFDIVV_D,
XFTRANS_S_D,
XFTRANS_D_S,
XHALT, (*BNDTRPKLU*)
XINC_S,
XJMPA,
XJMPZ_EQL_Q,
XJMPZ_NEQ_Q, (* als/peg 19jul79 *)
XJSR,
XMOV_A,
XMOV_Q_Q,
XMOV_Q_H,
XMOV_H_Q,
XMOV_H_H,
XMOV_Q_S,
XMOV_H_S,
XMOV_S_Q,
XMOV_S_H,
XMOV_S_S,
XMOV_Q_D,
XMOV_H_D,
XMOV_S_D,
XMOV_D_Q,
XMOV_D_H,
XMOV_D_S,
XMOV_D_D,
XMOVMQ_2,
XMOVMQ_3,
XMOVMQ_4,
XMOVMQ_5,
XMOVMQ_6,
XMOVMQ_7,
XMOVMQ_8,
XMOVMQ_9,
XMOVMQ_10,
XMOVMQ_11,
XMOVMQ_12,
XMOVMQ_13,
XMOVMQ_14,
XMOVMQ_15,
XMOVMQ_16,
XMOVMQ_17,
XMOVMQ_18,
XMOVMQ_19,
XMOVMQ_20,
XMOVMQ_21,
XMOVMQ_22,
XMOVMQ_23,
XMOVMQ_24,
XMOVMQ_25,
XMOVMQ_26,
XMOVMQ_27,
XMOVMQ_28,
XMOVMQ_29,
XMOVMQ_30,
XMOVMQ_31,
XMOVMQ_32,
XMOVMQ_64,
XMOVMQ_128,
XMOVMS_2, (*through MOVMS_32 added 5/dec/78 ALS*)
XMOVMS_3,
XMOVMS_4,
XMOVMS_5,
XMOVMS_6,
XMOVMS_7,
XMOVMS_8,
XMOVMS_9,
XMOVMS_10,
XMOVMS_11,
XMOVMS_12,
XMOVMS_13,
XMOVMS_14,
XMOVMS_15,
XMOVMS_16,
XMOVMS_17,
XMOVMS_18,
XMOVMS_19,
XMOVMS_20,
XMOVMS_21,
XMOVMS_22,
XMOVMS_23,
XMOVMS_24,
XMOVMS_25,
XMOVMS_26,
XMOVMS_27,
XMOVMS_28,
XMOVMS_29,
XMOVMS_30,
XMOVMS_31,
XMOVMS_32,
XMULT_S,
XMULT_D,
XDIV_S, (* added 18jul79 als/peg *)
XNEG_Q,
XNEG_H,
XNEG_S,
XNEG_D,
XNOP,
XOR_Q,
XOR_D,
XQUO_S,
XQUOV_S,
XQUO_D,
XQUOV_D,
XREM_S,
XREMV_S,
XREM_D,
XREMV_D,
XRETSR,
XSHF_LF_D,
XSHFV_LF_D,
XSHFA_LF_S,
XSHFAV_LF_S,
XSKP_EQL_Q, (*Start of S1SKIPOPCODE subrange*)
XSKP_NEQ_Q,
XSKP_GEQ_Q,
XSKP_GTR_Q,
XSKP_LEQ_Q,
XSKP_LSS_Q,
XSKP_EQL_H,
XSKP_NEQ_H,
XSKP_GEQ_H,
XSKP_GTR_H,
XSKP_LEQ_H,
XSKP_LSS_H,
XSKP_EQL_S,
XSKP_NEQ_S,
XSKP_GEQ_S,
XSKP_GTR_S,
XSKP_LEQ_S,
XSKP_LSS_S,
XSKP_EQL_D,
XSKP_NEQ_D,
XSKP_GEQ_D,
XSKP_GTR_D,
XSKP_LEQ_D,
XSKP_LSS_D,
XSKP_NON_Q,
XSKP_NON_H,
XSKP_NON_S,
XSKP_NON_D,
XSKP_ANY_Q,
XSKP_ANY_H,
XSKP_ANY_S,
XSKP_ANY_D, (*End of S1SKIPOPCODE subrange*)
XSLR_0,
XSLR_1,
XSLR_2,
XSLR_3,
XSLR_4,
XSLR_5,
XSLR_6,
XSLR_7,
XSLR_8,
XSLR_9,
XSLR_10,
XSLR_11,
XSLR_12,
XSLR_13,
XSLR_14,
XSLR_15,
XSLR_16,
XSLR_17,
XSLR_18,
XSLR_19,
XSLR_20,
XSLR_21,
XSLR_22,
XSLR_23,
XSLR_24,
XSLR_25,
XSLR_26,
XSLR_27,
XSLR_28,
XSLR_29,
XSLR_30,
XSLR_31,
XSLRADR_0,
XSLRADR_1,
XSLRADR_2,
XSLRADR_3,
XSLRADR_4,
XSLRADR_5,
XSLRADR_6,
XSLRADR_7,
XSLRADR_8,
XSLRADR_9,
XSLRADR_10,
XSLRADR_11,
XSLRADR_12,
XSLRADR_13,
XSLRADR_14,
XSLRADR_15,
XSLRADR_16,
XSLRADR_17,
XSLRADR_18,
XSLRADR_19,
XSLRADR_20,
XSLRADR_21,
XSLRADR_22,
XSLRADR_23,
XSLRADR_24,
XSLRADR_25,
XSLRADR_26,
XSLRADR_27,
XSLRADR_28,
XSLRADR_29,
XSLRADR_30,
XSLRADR_31,
XSUB_S,
XSUBV_S,
XSUB_D,
XSUBV_D,
XTRANS_Q_Q,
XTRANS_Q_H,
XTRANS_H_Q,
XTRANS_H_H,
XTRANS_Q_S,
XTRANS_H_S,
XTRANS_S_Q,
XTRANS_S_H,
XTRANS_S_S,
XTRANS_Q_D,
XTRANS_H_D,
XTRANS_S_D,
XTRANS_D_Q,
XTRANS_D_H,
XTRANS_D_S,
XTRANS_D_D,
XXOR_Q);
HARDS1OPCODE = 0..4095;
S1SKIPOPCODE = XSKP_EQL_Q..XSKP_ANY_D;
(*
OPNDTYPE = (ILLARITH, ILLCOMP,
TYPA, TYPM, TYPN, TYPB, TYPC, TYPS, TYPQ,
TYPH, TYPI, TYPD, TYPX, TYPR, TYPP, TYPJ);
*)
OPNDTYPE = (ILLARITH, ILLCOMP,
TYPUA, TYPUB, TYPUC, TYPUE, TYPQ, TYPH, TYPUI, TYPUJ, TYPUK,
TYPUL, TYPUM, TYPUN, TYPUP, TYPUQ, TYPUR, TYPUS);
MEMTYPE = (NON_SPACE, R_SPACE, M_SPACE);
S1PRECISION = (S1ILLEGAL, S1Q, S1H, S1S, S1D);
S1LENGTH = 0..8; (*QW LENGTH OF A BASIC S1 PRECISION*)
S1OPFORMAT = (VFAKEOP, VTOP, VJOP, VXOP, VSOP);
ALIGNMENTBOUNDARY = 0..MAXALIGNBOUNDARY;
S1REGISTER = FIRSTS1REG..LASTS1REG;
SETOFS1REGS = set of S1REGISTER; (*PEG*)
S1GBL = FIRSTS1GBL..LASTS1GBL;
S1ADDRESS = 0..MAXS1ADDR;
S1DISP = MINS1DISP..MAXS1DISP;
S1BITNUM = 0..35;
S1SKIPDISTANCE = MINSKPOFFSET..MAXSKPOFFSET;
BIT = 0..1;
TWOBITS = 0..3;
OPND_INTEGER = 0 .. 4095; (*8MAR79 PTZ*)
S1RELADR = 0..1073741823; (*2**30 - 1*)
ESDINDEX = 1..MAXESDINDEX;
ESRINDEX = 1..MAXESRINDEX;
ZINDEX = 1..MAXZINDEX;
BANK = integer (*should be (RGS, MEM), but alignment*);
LINTVAL_OR_LCODEPTR = (LINTVAL,LCODEPTR);
XW_EV_OR_XW_C = (XW_EV,XW_C);
A_CODEREC = ↑CODEREC;
A_LBLHASHENT = ↑LBLHASHENT;
A_PROCENT = ↑PROCENT;
BITFIELD_LENGTH = 1..WORDBITS;
LBL_INDEX = -2..MAXLBL; (* labels -2 to 0 reserved for SOPA use (DEF,XJP) *)
NUMBER_OF_PAREGS = 0..MAXPAREG;
RNG_0_LBLHTSIZEM1 = 0..LBLHTSIZEM1;
DTYPE_LENGTH = 0..STRINGBITMAX; (*bit length for valid UCode entities*)
INDIRECTION = (IND0, IND1, IND2);
SFLDRNG = 0..SFLDMAX; (*VPA shift range*)
STKINX = MINSTKINX..MAXSTKINX;
FRAMEINX = MINFRAME..MAXFRAME; (* peg 09jul79 *)
OPNDTYPE_TO_BOOLEAN_ARRAY = array [OPNDTYPE] of boolean;
(*When *real* S1 words exist, this will just be an integer.*)
S1WORD = (*Moved by PEG to resolve forward ref. by S1SETREP.*)(*setch*)
record
LHALF, RHALF : integer
end (*S1WORD*);
(*setch...*)
HOST_SET_EL_TYP = 0..HOST_SET_MAX;
HOST_SET_TYP = set of HOST_SET_EL_TYP; (*Set available on host machine.*)
SET_EL_TYP = 0..SET_MAX;
SETREP_INDEX = 0..SETREP_MAX; (*X10S1/FULL*)
SETREP = array [SETREP_INDEX] of HOST_SET_TYP; (*X10S1/FULL*)
(*SOPA-internal representation of full S1 set.*)
(* SETREP = HOST_SET_TYP; *) (*X10S1/FULL*)
S1SETREP_INDEX = 0..S1SETREP_MAX;
S1SETREP = array [S1SETREP_INDEX] of S1WORD; (*S1 set representation.*)
SETPART_INDEX = 0..SETPART_MAX;
(*...setch*)
char = ascii; (*X10S1-- PEG*)
CHAR2 = packed array [1..2] of char;
CHAR3 = packed array [1..3] of char;
CHAR4 = packed array [1..4] of char;
CHAR10 = packed array [1..10] of char;
CHAR12 = packed array [1..12] of char;
CHAR15 = packed array [1..15] of char;
CHAR17 = packed array [1..17] of char;
ALFALEN = 1..ALFASIZE;
ALFA = packed array [ALFALEN] of char;
NAMEREC = record NAM : ALFA; LEN : ALFALEN end;
STRINGTYPE = packed array [1..STRINGMAX] of char; (*als/peg 24jul79*)
STRINX = 0..STRINGMAX; (*als/peg 24jul79*)
NONNEGINT = 0..MAX_ON_COMP_MACH;
ZSYMBOL = packed array [1..8] of char; (*external symbol name*)
ZSEGTYPE = (ZIS,ZDS,ZCM);
ZESDTYPE = (ZST,ZIN,ZDN,ZAN);
ZESRTYPE = (ZIR,ZDR,ZAR,ZXR);
ZOPR = (ZPLUS,ZMINUS);
ZESDESRSEG = (ZESD,ZESR,ZSEG);
CODEREC =
record
NEXTPTR : A_CODEREC;
case BIT of
0 : (CODEWORD : S1WORD);
1 : (CODEPTR : A_CODEREC)
end (*CODEREC*);
CODEREC_PTRINT = (* a kludge for printing ptr values for debugging *)
record (*14JAN79 PTZ*)
case BIT of
0 : (PTR : A_CODEREC);
1 : (INT : integer);
end (*CODEREC_PTRINT*);
CODELIST = (*linked via NEXTPTR*)
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : A_CODEREC;
end (*CODELIST*);
JUMPLIST = (*linked via CODEPTR*)
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : A_CODEREC;
end (*JUMPLIST*);
RTSTACK = (*peg 25jul79...*)
record
SIZE : integer;
FIXLIST, NEGFIXLIST : CODELIST
end (*RTSTACK*); (*...peg 25jul79*)
LBLHASHENT =
record
LBLNUM : LBL_INDEX;
NEXTPTR : A_LBLHASHENT;
DEFINED : boolean;
BRANCH_CNT : integer; (* peg 02jul79 *)
case LINTVAL_OR_LCODEPTR of
LINTVAL : (INTVAL : integer; CLIST : CODELIST);
LCODEPTR : (CODEPTR : A_CODEREC; JLIST : JUMPLIST;
JUMPTABLELABEL : boolean)
end (*LBLHASHENT*);
PROCENT =
record
NAME : ALFA;
FIXLIST : CODELIST;
NEXTPTR : A_PROCENT
end (*PROCENT*);
PROCSPEC = (* peg 18jul79...*)
record
PROCTYPE : OPNDTYPE;
PROCNAM : NAMEREC;
PARMS_POPPED,
RESULTS_PUSHED,
REGPARMAREA, (* in quarterwords *)
R_MEMORY_AREA, (* in bits...*)
M_MEMORY_AREA : (*...in bits *)
integer;
end (*PROCSPEC*); (*...peg 18jul79 *)
MSTENTRY =
record
DESTLEV : 1..MAXLVL; (*level of callee*)
CURPARMREGS : NUMBER_OF_PAREGS;
(*number of parmregs used by caller*)
EVALSAVESTART : integer;
(*displacement into the evalsave of the
low end of the section used by this call*)
MSTCODESTART : A_CODEREC; (*Start of code from MST
(NEWINSTREC at entry to UMST)*)
end (*MSTENTRY*);
OPERANDXWORD =
record
case FMT : XW_EV_OR_XW_C of
XW_EV : (P, V, D, I : BIT;
S : 0..MAXINDEXSHIFT;
ADDR : S1ADDRESS;
REG : S1REGISTER;
DISP : S1DISP );
XW_C : (VAL : S1WORD)
end (*OPERANDXWORD*);
OPERAND =
record
X : BIT;
REG : S1REGISTER;
F : MINSHORTOFFSET..MAXSHORTOFFSET;
XW : OPERANDXWORD;
FIXUP : (NOFIX, STRINGFIX, SETFIX, REALFIX,
XTRNSYMFIX, BOUNDFIX);
FIXPTR : A_PROCENT; (*used only for XTRNSYMFIX*)
end (*OPERAND*);
LVLDSP =
record
DSPLMT : integer;
LVL : 0..MAXLVL
end (*LVLDSP*);
MEMOREG =
record
case WHICH : BANK of
RGS : (RGADR : S1REGISTER);
MEM : (MEMADR : LVLDSP)
end (*MEMOREG*);
VPAREC =
record
VSHIFT : SFLDRNG; (*amount to shift part after
evaluation and indirection.*)
VPAIND : IND1..IND2; (*indirection on this variable part.*)
VPA : MEMOREG; (*memory or register location.*)
end (*VPAREC*);
(*Type DATUM is the crux of this program. It represents a quantity on
the P-Machine stack during the process of executing the P-Code program
being translated. This quantity can be constant, in which case we have
its value in the datum; it may be a variable, in which case we have its
address in register or memory; or it may be a computed value, in which
case we may have the address of a temporary register containing the
quantity, or we may have several of any of the above along with other
information which all together tells what computation is needed beyond
the code which has already been emitted in order to calculate the
quantity.
The process of evaluating a datum can be described as follows. A
'MEMOREG' represents a register or memory address in the S1. Unless
indirected, the quantity represented is that address; thus the value of
a FPA with LVL=1 and DSPLMT=100 is the *address* of the 100th unit after
the unit addressed by the level 1 display register. We consider this a
constant even though it clearly depends on the run-time value of a
register.
If the MEMOREG is in a VPA, more may be done to it. A VPA has an
indirection associated with it of either 1 or 2. A VPA MEMOREG with
indirection 1 represents the quantity at the address described by the
MEMOREG. If the indirection is 2, the MEMOREG describes an address
where there is another address. The contents of the location at that
second address is the value of the quantity. After the appropriate
indirection is done, there may be a shift applied to the quantity (e.g.
if it is to be an index). Note that such a shift is applied after the
VPA indirection.
After the FPA and any active VPAs have been completely evaluated, we add
together their values and indirect the sum 0, 1, or 2 more times to get
the value of the datum itself. Thus for example if FINALIND is 0 the
datum value is the sum of the part values; if FINALIND is 1 the sum is
the *address* of the datum value. *)
DATUM =
record
CODESTART : A_CODEREC; (*pointer to first S1 instruction
in the evaluation of this datum*)
DTYPE : OPNDTYPE;
DLENGTH : DTYPE_LENGTH; (*bit length of item*)
MTYPE : MEMTYPE;
(*The following five fields only apply to booleans.*)
BREPRES : (BINTVAL, BJUMP);
(*tells whether boolean is represented
as a 0..1 value or as jump structure*)
BTRUELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be true*)
BFALSELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be false*)
BFALLTHRUSKIPLOC : A_CODEREC;
(*loc of last skip around jump in
code to evaluate boolean*)
BJUMPON : boolean; (*truth value for datum on which the
jump after the fallthruskip jumps*)
(*End of special boolean fields.*)
SCNST : SETREP; (*set value if set constant*)
RCNST : real; (*real value if real constant*)
FINALIND : IND0..IND2;
(*Final indirection depth of represented quantity.
IND0 : constant or constant wrt base.
IND1 : one indirection applied after evaluation.
IND2 : two indirections applied after evaluation.
FINALIND *must* be IND0 if there is no VPA
or if there is no FPA and only one VPA and that VPA
is at indirection IND1. That is, an indirection
applied to an FPA is recorded by making it a VPA,
and an indirection applied to a single VPA with
small internal indirection is recorded by increasing
that internal indirection.*)
FPA : MEMOREG; (*accumulated additive fixed part*)
NVPAS : 0..2; (*number of active VPAs. If only 1,
VPA1 is the active one.*)
VPA1 : VPAREC; (*variable parts : contents of the*)
VPA2 : VPAREC; (*described register or memory loc.*)
end (*DATUM*);
var
PRR : text; (*X10S1*)
OPC : U_OPCODE;
MNEM : CHAR4;
TYP : OPNDTYPE;
TYPO2 : OPNDTYPE;
MTYP: MEMTYPE;
I1, I2, I3, I4, I5, I6, I7 : integer; (*14JAN79 PTZ*)
R1 : real;
P1 : SETREP;
NAM0, NAM1, NAM2 : NAMEREC;
SVAL : STRINGTYPE;
SLGTH : STRINX;
ASMPC : INTEGER;
UNKT : boolean; (* To allow unknown UNK instructions *)
PWORDCOUNT, (* als/peg 17jul79 *)
PSTRCOUNT : NONNEGINT; (* als/peg 13jul79 *)
PREGS_ARCHIVED : boolean; (* als/peg 18jul79 *)
TR_UCODE, TR_S1CODE, TR_SIMP, TR_PEEPHOLE, (*14JAN79 PTZ*)
TR_STACK, TR_MST %, TR_NEST\ : boolean; (* peg 18jul79 *)
OLDINSTREC : A_CODEREC;
OLDTOP : STKINX;
OLDMSTTOP : 0..MAXMST;
UNKNOWN_LOC : integer;
ASM : boolean;
DEBUG : boolean;
NO_JMPX_TO_JMPA_FLG : boolean; (*14JAN79 PTZ...*)
NO_COLLAPSE_MOV_FLG : boolean;
NO_SKIP_JMPA_FLG : boolean; (*...14JAN79 PTZ*)
ASSERTCOUNT : integer;
CURPC : integer;
MAINCODE : CODELIST;
NEWINSTREC : A_CODEREC;
ERRINT1 : integer;
STRINGAREA : CODELIST;
NXTSTRDISP : integer;
STRINGAR_CPTR : A_CODEREC;
REALTBL, SETTBL, LOCTBL, BOUNDTBL : CODELIST;
STRINGFIXLIST, REALFIXLIST, SETFIXLIST, BOUNDFIXLIST : CODELIST;
NEG_SHIFT_FIXLIST : CODELIST;
(*Instructions on this list have OPND2s whose XW displacement
needs to be negated and shifted left at gen-segment time.*)
STACKFRAME : RTSTACK; (*als/peg 25jul79*)
EVALSAVE : RTSTACK;
PROCTBL : record
NPROCS : integer;
FIRST : A_PROCENT
end (*PROCTBL*);
LBLHASHTAB : array [RNG_0_LBLHTSIZEM1] of A_LBLHASHENT;
CSPHASHTAB : array [0..CSPHTSIZEM1] of
record
CSPNAM : NAMEREC;
CSP : P_STANDARDPROC
end (*CSPHASHTAB*);
OPCHASHTAB : array [0..OPCHTSIZEM1] of
record
OPCNAM : CHAR4;
OPC : U_OPCODE
end (*OPCHASHTAB*);
FIRSTTYPE, LASTTYPE : OPNDTYPE;
FIRSTMTYPE, LASTMTYPE, DEFAULTMTYPE : MEMTYPE;
FIRSTS1OP, LASTS1OP : S1OPCODE;
FIRSTSKIP, LASTSKIP : S1OPCODE;
ZERO_OP, EXTENDED_ZERO_OP : OPERAND; (*specify constant 0*)
EMPTY_OP : OPERAND; (*initted to valid but indeterminate value*)
UNUSED_OP : OPERAND; (*specify R0 for unused operands*)
ZEROS1WORD : S1WORD;
ZEROFPA : MEMOREG;
ZEROVPA : VPAREC;
ZERODATUM : DATUM;
EMPTYCODELIST : CODELIST;
EMPTYJUMPLIST : JUMPLIST;
OPNDRTB : OPERAND; (*specifies RTB*)
OPNDRSP : OPERAND; (*specifies the SP*)
SEG_EP_RELPC : integer; (*constant SEG_START_RELPC+SEG_EP_DISP*)
NULL_SET : SETREP; (*for empty-set comparison/assign.*) (*setch*)
WHICHPART : SETPART_INDEX; (*for getting a particular piece of a
constant set out of the set table*)(*setch*)
TWOEXP : array [0..MAX_EXP_ON_COMP_MACH] of integer;
CURPROG : NAMEREC;
CURPROC, MAXTMPPROC : ALFA;
CURPLOC, MAXTMPPLOC : integer;
CURLVL, MAXLVLUSED : 0..MAXLVL;
CURPROCXN : NAMEREC;
DISPLAY : S1REGISTER;
OLDNP : A_CODEREC; (*saves heap top pointer so space can be
reclaimed after generation of segment*)
HARDOPCODE : array [S1OPCODE] of HARDS1OPCODE;
SOFTOPCODE : array [HARDS1OPCODE] of S1OPCODE;
REVERSE_OP : array [S1OPCODE] of S1OPCODE;
OPFORMAT : array [S1OPCODE] of S1OPFORMAT;
S1MNEM : array [S1OPCODE] of CHAR15;
DEST_PRECISION : array [S1OPCODE] of S1PRECISION; (*PTZ*)
COLLAPSIBLE_OP : array [S1OPCODE] of boolean; (*PBK*)
(* indication of whether an XOP or TOP can be collapsed with a
following MOV*) (*PBK*)
INVERSE_SKIP : array [S1SKIPOPCODE] of S1SKIPOPCODE;
TYPECODE : array [OPNDTYPE] of char;
MTYPECODE : array [MEMTYPE] of char;
ALIGNBNDRY : array [OPNDTYPE] of ALIGNMENTBOUNDARY;
S1SIZE : array [OPNDTYPE] of S1Q..S1D;
FUNCUNITS : array [OPNDTYPE] of S1LENGTH;
IS_DOUBLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_SINGLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_INTEGER : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_REAL : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_SIGNED_NUM : OPNDTYPE_TO_BOOLEAN_ARRAY;
SKP_NON_X : array [OPNDTYPE] of S1OPCODE;
MOV_X_X : array [OPNDTYPE] of S1OPCODE;
ABS_X : array [OPNDTYPE] of S1OPCODE;
NEG_X : array [OPNDTYPE] of S1OPCODE;
MOVMQ_N : array [1..MAXMOVMQ] of S1OPCODE;
MOVMS_N : array [1..MAXMOVMS] of S1OPCODE; (*5DEC78 ALS*)
FLOAT_S_X : array [OPNDTYPE] of S1OPCODE;
SLR_N : array [S1REGISTER] of S1OPCODE;
SLRADR_N : array [S1REGISTER] of S1OPCODE;
BTRP_B_X : array [OPNDTYPE] of S1OPCODE;
BTRP_N_X : array [0..1, OPNDTYPE] of S1OPCODE;
MOV_X_Y : array [OPNDTYPE, OPNDTYPE] of S1OPCODE;
ARITH_RESULT_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
COMPARE_COERCE_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
REAL_ARITH_OP : array [S1S..S1D, UADD..UDIV] of S1OPCODE;
COMPARE_OP : array [S1Q..S1D, UEQU..ULES] of S1OPCODE;
BLKCMP_X_Q : array [UIEQU..UILES] of S1OPCODE;
RISFREE : array [S1REGISTER] of boolean;
RPWORD : array [S1REGISTER] of
(RSINGLE, R1STOFPAIR, R2NDOFPAIR, R1STOFBLOCK, RINBLOCK);(*PBK*)(*PEG*)
GISFREE : array [S1GBL] of boolean;
NXTRG : S1REGISTER;
MINTMPS1REG, MAXTMPS1REG, MINDSPS1REG : S1REGISTER;
RTBUSER : STKINX; (*stack index for datum using RTB*)
RTBDOUB : boolean; (*true iff RTBUSER is a doubleword quantity*)
LVL_TO_S1REG : array [1..MAXLVL] of S1REGISTER;
PRM_TO_S1REG : array [0..MAXPAREGM1] of S1REGISTER;
S1REG_TO_PRM : array [S1REGISTER] of integer;
ZSEGTYPE_TO_CHARS : array [ZSEGTYPE] of CHAR4;
ZESDTYPE_TO_CHARS : array [ZESDTYPE] of CHAR4;
ZESRTYPE_TO_CHARS : array [ZESRTYPE] of CHAR4;
ZIXFLAG_TO_CHAR : array [ZESDESRSEG] of char;
ZOPR_TO_CHARS : array [ZOPR] of CHAR2;
LOCALSIZELNUM : LBL_INDEX;
BIGJUMPS : boolean; (*28APR79 PTZ*)
S1LOCS_INSERTED : boolean; (*28APR79 PTZ*)
JUMPS_CONCRETIZED : boolean;
JUMPTABLE_IN_PROGRESS : boolean;
STK : array [STKINX] of DATUM;
BOT, TOP : STKINX; (*BOT changed to var -- peg 09jul79*)
STKFRAME : array [FRAMEINX] of STKINX; (* peg 09jul79 *)
CURFRAME : FRAMEINX; (* peg 09jul79 *)
MSTSTK : array [0..MAXMST] of MSTENTRY;
MSTTOP : 0..MAXMST;
BLOCKTABLE : array [MINBLOCK..MAXBLOCK] of ILLBLOCKNO..MAXLVL;
CURPROCSPEC : PROCSPEC; (* peg 18jul79 *)
TIMER : integer;
ERRORCNT : NONNEGINT;
S1OP_CNT : array [S1OPCODE] of integer; (*LCW*)
S1OP_TOT : integer; (*LCW*)
S1OP : S1OPCODE; (*LCW*)
WORD_CNT : integer; (*LCW*)
PEEP_PASSES : integer; (*PTZ*)
GETFIELD_CNT : integer; (*PTZ*)
INSTR_WDS_REMOVED : integer; (*PTZ*)
J_TO_J_CNT : integer; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS : integer; (*PTZ*)
MOVS_COLLAPSED : integer; (*PTZ*)
(** ERROR_CLASS: ERREXIT ASSERTFAIL ERROR **)
(**)
function FLDW(NUM : integer) : integer;
forward;
procedure ERREXIT (CODE : integer);
begin
WRITELN(OUTPUT,'** * ERREXIT called with code =',CODE);
(* EXIT(4097) *) (*X10S1*)
HALT (*X10S1*)
end;
procedure ASSERTFAIL(MSG : CHAR12); (* ALS*)
(*ASSERTFAIL is used for internal consistency checking of the program.
The BOOLEAN that is a parameter in the ASSERT calls is here tested
before calling ASSERTFAIL, to avoid needless procedure calls.
The message in MSG is printed (to identify the particular
assertion) togather with an assertion count (now only a count of
the failed assertions) and execution is terminated. Note, that as it
is, only one failure will be reported. By not EXITTing one might get
more information from an attempted compilation.*)
begin
ASSERTCOUNT := ASSERTCOUNT + 1;
WRITELN(OUTPUT);
WRITELN(OUTPUT);
WRITELN(OUTPUT,'** ** ERROR ** ** Assertion #',ASSERTCOUNT:6,
' failed : ',MSG,' ** **');
(* ASSERTCOUNT := ASSERTCOUNT div (ASSERTCOUNT-ASSERTCOUNT); 17JAN79 EJG*)
ERREXIT(9999)
end (*ASSERTFAIL*);
procedure ERROR(CODE : ERRORCODE);
(*This procedure is called whenever an error condition is detected
in the input U-Code. At the very least, it prints a message
describing the error. For the time being, it then gives up the
ghost and halts execution.*)
begin
ERRORCNT := ERRORCNT + 1;
WRITE(OUTPUT,' *ERROR* ');
case CODE of
WARITH_ON_WRONG_DT :
begin
WRITELN(OUTPUT,'Arith on wrong data type')
end;
WNOT_IMPLEMENTED :
begin
WRITELN(OUTPUT,'Instruction not yet implemented')
end;
WILLEGAL_LABEL :
begin
WRITELN(OUTPUT,'Illegal label number or format')
end;
WABS_OR_NEG_OF_NONSIGNED :
begin
WRITELN(OUTPUT,'ABS or NEG applied to non-signed number')
end;
WADDR_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up address exceeds 30-bit S1 address space')
end;
WADDRESS_CHECK_ON_NONADDRESS :
begin
WRITELN(OUTPUT,'CHK type A applied to non-address')
end;
WALIGNMENT_ERROR :
begin
WRITELN(OUTPUT,'Alignment error')
end;
WANDOR_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'AND or IOR applied to non-boolean')
end;
WBGN_STP_NAME_MISMATCH :
begin
WRITELN(OUTPUT,
'Name parameters of BGN and STP do not match')
end;
WENT_AND_PLOD_INCONSISTENT :
begin
WRITELN(OUTPUT,
'Type parameters of ENT and PLOD do not match')
end;
WENT_END_NAME_MISMATCH :
begin
WRITELN(OUTPUT,
'Name parameters of ENT and END do not match')
end;
WENT_SPECIFIED_WRONG_PARMS :
begin
WRITELN(OUTPUT,
'ENT specified wrong number of parameters')
end;
WBINARY_OPND_TYPE_CONFLICT :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for binary operation')
end;
WBOOL_IS_TRUE :
begin
WRITELN(OUTPUT, 'CHKF: Boolean found to be not false')
end;
WBOOL_NOT_TRUE :
begin
WRITELN(OUTPUT, 'CHKT: Boolean found to be not true')
end;
WCHECKED_CONSTANT_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'CHK constant operand out of specified range')
end;
WCHKF_CHKT_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'CHKF or CHKT needs boolean')
end;
WCHKN_NULL_TOP :
begin
WRITELN(OUTPUT,'CHKN Top of stack is the nil pointer')
end;
WCHKN_NOT_ADDRESS :
begin
WRITELN(OUTPUT,'CHKN Top of stack not an address')
end;
WCHECKING_INVALID_TYPE :
begin
WRITELN(OUTPUT,'CHK applied to invalid operand type')
end;
WCHR_NEEDS_INT :
begin
WRITELN(OUTPUT,'CHR applied to non-integer')
end;
WCOERCION_INVALID :
begin
WRITELN(OUTPUT,'Invalid type coercion')
end;
WCOMPARE_ILLEGAL :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for compare operation')
end;
WCOMPM_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'Compare type M applied to non-address')
end;
WCONST_OUT_OF_RANGE_FOR_SET :
begin
WRITELN(OUTPUT,'Constant is out of range for set')
end;
WDISP_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WDUP_ON_EMPTY_STACK :
begin
WRITELN(OUTPUT,'DUP with empty stack')
end;
WEQU_etc_with_TYP_is_TYPM :
begin
WRITELN(OUTPUT,'EQU..NEQ with TYP=TYPUM in UCODE')
end;
WEXPR_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Expression too complex (or total proc nesting too deep)')
end;
WFILE_ADDRESS_NEEDED :
begin
WRITELN(OUTPUT,'Stack top must be file address')
end;
WTJP_FJP_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'TJP or FJP with non-boolean stack top')
end;
WTJP_FJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'TJP or FJP with non-singleton expr stack')
end;
WFIX_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'RND applied to invalid operand type')
end;
WFLOAT_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,
'FLO or FLT applied to invalid operand type')
end;
WFUNC_CALLS_NESTED_TOO_DEEPLY :
begin
WRITELN(OUTPUT,
'Function calls nested too deeply in expression')
end;
WIEQU_etc_with_TYP_not_TYPM :
begin
WRITELN(OUTPUT,'IEQU..INEQ with TYP<>TYPUM in UCODE')
end;
WILLEGAL_PROC_TYPECODE :
begin
WRITELN(OUTPUT,
'Invalid procedure type in U-Code instruction')
end;
WINCOMPATIBLE_TYPES :
begin
WRITELN(OUTPUT,'Incompatible types for storing')
end;
WINDEX_WITHOUT_BASE :
begin
WRITELN(OUTPUT,'IND on (shifted) index without base')
end;
WINDEXING_IN_PARMS :
begin
WRITELN(OUTPUT,
'Indexing within fast (register) parameter area')
end;
WINN_REQUIRES_SET_ON_TOP_OF_STACK :
begin
WRITELN(OUTPUT,'INN on non-set second operand')
end;
WINSTR_TYPE_NOT_DATUM_TYPE :
begin
WRITELN(OUTPUT, 'Type in U-Code command different',
' from type of stack top.')
end;
WINSUFF_PARMS_SPECIFIED :
begin
WRITELN(OUTPUT,
'CUP specified fewer parameters than are on stack')
end;
W2_MANY_PARMS_SPECIFIED :
begin
WRITELN(OUTPUT,
'CUP specified more parameters than are on stack')
end;
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO :
begin
WRITELN(OUTPUT,'DVI or mod by integer constant zero')
end;
WINVAL_BLOCK_NUMBER :
begin
WRITELN(OUTPUT, 'Invalid memory block number')
end;
WINVAL_CSP :
begin
WRITELN(OUTPUT, 'Invalid standard procedure name')
end;
WINVAL_OPC :
begin
WRITELN(OUTPUT, 'Invalid U-Code opcode:',OPC)
end;
WINVAL_TRACE :
begin
WRITELN(OUTPUT, 'Invalid trace argument')
end;
WINVAL_U_TYPECODE :
begin
WRITELN(OUTPUT, 'Invalid type in U-Code instruction')
end;
WINVAL_TYP_ON_LDC :
begin
WRITELN(OUTPUT,'LDC type argument invalid')
end;
WINVALID_DISPLACEMENT :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WINVALID_TYPE_COERCION :
begin
WRITELN(OUTPUT,'Invalid type coercion')
end;
WINVALID_LEVEL :
begin
WRITELN(OUTPUT, 'Invalid level in U-Code instruction')
end;
WINVALID_MEMORY_TYPE :
begin
WRITELN(OUTPUT, 'Invalid memory type in U-Code instruction')
end;
WIXA_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'IXA on non-address first operand')
end;
WLAST_SST_PARM_TOO_BIG :
begin
WRITELN(OUTPUT, 'Last SST parameter bigger than MAXPAREG')
end;
WL_LPTR_LBLNUM_UNDEFINED :
begin
WRITELN(OUTPUT,
'Undefined label : L',ERRINT1:FLDW(ERRINT1))
end;
WLOADING_STRING :
begin
WRITELN(OUTPUT,
'IND loading string (indirect thru string constant illegal)')
end;
WISTR_INST_NEEDS_ADDRS :
begin
WRITELN(OUTPUT,'ISTR or INST with non-address operand')
end;
WMOV_NEEDS_ADDRS :
begin
WRITELN(OUTPUT,'MOV with non-address operand(s)')
end;
WMST_SPECIFIED_INSUFF_PARM_STORAGE :
begin
WRITELN(OUTPUT,
'MST specified insufficient parameter storage')
end;
WMST_WITHOUT_CUP_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,
'MST without corresponding CUP in last segment')
end;
WMULT_DEFINED_LAB :
begin
WRITELN(OUTPUT,'Multiply defined label')
end;
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Total proc nesting too deep (or some expr too complex)')
end;
WNEW_MUST_HAVE_ADDR_AND_INT :
begin
WRITELN(OUTPUT,
'NEW operands not (1) address and (2) integer')
end;
WNOT_AN_ADDR :
begin
WRITELN(OUTPUT,'ILOD applied to non-address type')
end;
WNOT_DISCRETE_TYPE :
begin
WRITELN(OUTPUT,
'INC, DEC, PRE, or SUC applied to non-discrete type')
end;
WNOT_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'NOT applied to non-boolean')
end;
WNULLREF :
begin
WRITELN(OUTPUT,'IND applied to nil')
end;
WODD_REQUIRES_AN_INTEGER :
begin
WRITELN(OUTPUT,'ODD applied to non-integer')
end;
WORD_NEEDS_INT_BOOLEAN_OR_CHAR :
begin
WRITELN(OUTPUT,
'ORD operand not integer, boolean, or char')
end;
WPOP_OF_EMPTY_STACK :
begin
WRITELN(OUTPUT,
'Pop of empty expr stack (stack underflow)')
end;
WREAL_CONSTANT_DIVISION_BY_ZERO :
begin
WRITELN(OUTPUT,'DVR by real constant zero')
end;
WREGPARMS_SPEC_TOO_LOW_IN_MST :
begin
WRITELN(OUTPUT,
'MST specified insufficient register parameter storage')
end;
WRST_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'RST operand not address')
end;
WSAV_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'SAV operand not address')
end;
WSET_OPERATION_ON_NONSET_TYPES :
begin
WRITELN(OUTPUT,'Set operation applied to non-set')
end;
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN :
begin
WRITELN(OUTPUT,
'SGS or INN (first) operand not integer, boolean, or char')
end;
WSIO_DIDNT_SEE_FILEADDR :
begin
WRITELN(OUTPUT,'SIO didnt see file addr')
end;
WSIO_WITH_NONADDRESS :
begin
WRITELN(OUTPUT,'SIO operand not address')
end;
WSQUARE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'SQR operand type invalid')
end;
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,'Expr stack left nonempty in last segment')
end;
WSTACK_NON_EMPTY :
begin
WRITELN(OUTPUT, 'Expression stack should have been ',
'empty after last instruction')
end;
WSTACK_NOT_SINGLE :
begin
WRITELN(OUTPUT, 'Expression stack should have ',
'contained exactly one element ',
'after last instruction')
end;
WSWP_NOT_2 :
begin
WRITELN(OUTPUT,'SWP with less than 2 DATUMs on STACK')
end;
WSWP_TYP_ERROR :
begin
WRITELN(OUTPUT,'SWP operand types specified incorrectly')
end;
W2_MANY_BGNBS :
begin
WRITELN(OUTPUT,
'Too many BGNB instructions encountered: stack overflow')
end;
W2_MANY_ENDBS :
begin
WRITELN(OUTPUT,
'Too many ENDB instructions encountered: stack underflow')
end;
WTOO_LARGE_K_OR_L :
begin
WRITELN (OUTPUT,'Too large non-neg. integer')
end;
WTRUNCATE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'TRC operand type invalid')
end;
WCVT_WITH_INVALID :
begin
WRITELN(OUTPUT,'CVT or CVT2 instruction with invalid dtype')
end;
WTYP_WITH_INVALID :
begin
WRITELN(OUTPUT,'TYP or TYP2 instruction with invalid dtype')
end;
WUJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'UJP with nonempty expr stack')
end;
WWRONG_COMPARE :
begin
WRITELN(OUTPUT,
'Wrong compare operator for given operand types')
end;
WWRONG_INSTR_DATATYPE :
begin
WRITELN(OUTPUT,
'Invalid data type for this instruction')
end;
WWRONG_RESULT_NUMBER :
begin
WRITELN(OUTPUT,
'CUP instruction specified wrong number of function',
' results--(no value-result parmeters allowed');
end;
WXJP_WITHOUT_SINGLETON_STACK :
begin
WRITELN(OUTPUT,'XJP with non-singleton expr stack')
end
end (*case*);
if not (FALSE) then
ASSERTFAIL('ERROR 999'); (*temporary to get traceback*)
ERREXIT(1000) (*Basic giving-up-the-ghost action.*)
end (*ERROR*);
(** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTMTYP PRINTINT **)
(**)
function IS_CONSTANT (STE : STKINX) : boolean;
forward;
procedure DISASSEMBLE(var CURPC : integer; IPTR : A_CODEREC);
forward;
function GETS1OPCODE (INSTLOC : A_CODEREC) : S1OPCODE;
forward;
function JUMPSKIPDEST(INSTLOC : A_CODEREC) : A_CODEREC;
forward;
function SET_IN(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean;
forward;
procedure PRINTSET (S : SETREP);
(*Print the set.*)
var I : SET_EL_TYP; (*setch*)
COUNT : integer;
begin
WRITE (OUTPUT, ' [');
COUNT := 0;
for I := 0 to SET_MAX do
if SET_IN(I,S) then (*setch*)
begin
if COUNT > 15 then (*setch*)
begin
WRITELN(OUTPUT);
WRITE (OUTPUT, ' ');
COUNT := 0;
end;
WRITE (OUTPUT, I : 4);
COUNT := COUNT + 1;
end;
WRITELN (OUTPUT, '].');
end (*PRINTSET*);
procedure PRINTSTRING(var STRVAL : STRINGTYPE; var STRLGTH : STRINX);
(*Print a string from STRVAL -- als/peg 24jul7.*)
var I : STRINX;
begin
for I := 1 to STRLGTH do
WRITE (OUTPUT, STRVAL[I]);
end (*PRINTSTRING*);
procedure PRINTMEMOREG (var X : MEMOREG);
(*Print the memoreg without changing lines.*)
begin
if X.WHICH = RGS then
begin
if X.RGADR = S1RTA then
WRITE (OUTPUT, 'RTA')
else if X.RGADR = S1RTB then
WRITE (OUTPUT, 'RTB')
else
WRITE (OUTPUT, 'R', ord(X.RGADR) : FLDW(ord(X.RGADR)) )
end
else if X.MEMADR.LVL = 0 then
WRITE (OUTPUT, X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT) )
else
WRITE (OUTPUT, '<L', X.MEMADR.LVL : FLDW(X.MEMADR.LVL),
',', X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT), '>' );
end (*PRINTMEMOREG*);
procedure PRINTDATUM (STE : STKINX);
(*Print the datum for trace or debugging purposes.*)
var PTR : A_CODEREC;
I : integer;
UNKNOWN_LOC : integer;
begin
with STK[STE] do
begin
WRITELN (OUTPUT, ' STK[', STE : FLDW(STE), '] IS' );
WRITE (OUTPUT, ' TYP', TYPECODE[DTYPE], ' = ');
if (DTYPE = TYPUR) and IS_CONSTANT(STE) then
WRITELN (OUTPUT, RCNST)
else if (DTYPE = TYPUS) and IS_CONSTANT(STE) then
PRINTSET (SCNST)
else if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin
WRITELN (OUTPUT, 'BJUMP with', BTRUELIST.NWORDS : 3,
' true jumps and', BFALSELIST.NWORDS : 3,
' false jumps.' );
WRITE (OUTPUT, ' BJUMPON is ');
if BJUMPON then WRITE (OUTPUT, 'TRUE')
else WRITE (OUTPUT, 'FALSE');
WRITELN (OUTPUT, ' and fall thru skip is');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, BFALLTHRUSKIPLOC);
PTR := BTRUELIST.FIRST;
for I := 1 to BTRUELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU001');
PTR := JUMPSKIPDEST(PTR);
end;
PTR := BFALSELIST.FIRST;
for I := 1 to BFALSELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU002');
PTR := JUMPSKIPDEST(PTR);
end;
end
else
begin
WRITE (OUTPUT, ord(FINALIND) : 1, ': (' );
PRINTMEMOREG (FPA);
if NVPAS > 0 then
begin
WRITE (OUTPUT, ', ', ord(VPA1.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA1.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA1.VSHIFT] : 1 );
end;
if NVPAS = 2 then
begin
WRITE (OUTPUT, ', ', ord(VPA2.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA2.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA2.VSHIFT] : 1 );
end;
WRITELN (OUTPUT, ').' );
end;
WRITE (OUTPUT,
' Code starts with the instruction ');
if CODESTART = NEWINSTREC then
WRITELN (OUTPUT, 'at NEWINSTREC.')
else if CODESTART = nil then
writeln (OUTPUT, '??? NIL pointer.')
else
WRITELN (OUTPUT, S1MNEM[GETS1OPCODE(CODESTART)] );
end (*with*);
end (*PRINTDATUM*);
%procedure PRINT_NESTITEM (INDEX : integer); (*commented out by*)
(*Print NESTDISPLAY[INDEX].*) (* peg 18jul79 *)
begin
with NESTDISPLAY[INDEX] do
begin
WRITELN (OUTPUT, ' NESTDISPLAY[',
INDEX : FLDW(INDEX), '] IS' );
WRITELN (OUTPUT, ' ', PROCNAM.NAM, ' TYP', TYPECODE[PROCTYPE],
' areas ', REGPARMAREA, FIRSTPARMAREA,
L_MEMORY_AREA, M_MEMORY_AREA );
WRITELN (OUTPUT, ' displacements', LCBEFPAR,
OFFSET_IN_VARS, LOCALDATAOFFSET,
LOCALDATATRANSLATION );
end (*with*);
end (*PRINT_NESTITEM*); \(*end comment out*)
procedure PRINT_MSTENTRY (INDEX : integer);
(*Print MSTSTK[INDEX].*)
begin
with MSTSTK[MSTTOP] do
begin
WRITELN (OUTPUT, ' MSTSTK[',
INDEX : FLDW(INDEX), '] is' );
WRITELN (OUTPUT, ' lev', DESTLEV : 2,
', pregs', CURPARMREGS : 3 );
WRITELN (OUTPUT,
' evalsave', EVALSAVESTART : FLDW(EVALSAVESTART));
end (*with*);
end (*PRINT_MSTENTRY*);
procedure PRINTNXTINST;
(*Print next P-Code instruction.*)
procedure PRINTNAM (var NAM : NAMEREC);
(*Print two spaces and the name.*)
var I : ALFALEN;
begin
WRITE (OUTPUT, ' ');
for I := 1 to NAM.LEN do WRITE (OUTPUT, NAM.NAM[I]);
end (*PRINTNAM*);
procedure PRINTTYP (TYP : OPNDTYPE);
(*Print two blanks and the type code.*)
begin
WRITE (OUTPUT, ' ', TYPECODE[TYP]);
end (*PRINTTYP*);
procedure PRINTMTYP (TYP : MEMTYPE);
(*Print two blanks and the memory type code.*)
begin
WRITE (OUTPUT, ' ', MTYPECODE[TYP]);
end (*PRINTTYP*);
procedure PRINTINT (I : integer);
(*Print two blanks and the integer.*)
begin
WRITE (OUTPUT, ' ', I : FLDW(I));
end (*PRINTINT*);
begin
if (OPC = ULAB) or (OPC = UENT) or (OPC = UCLAB) or (OPC = USYM) then
PRINTNAM (NAM0)
else
WRITE (' ');
WRITE (OUTPUT, ' ', MNEM);
case OPC of
UCHKF, UCHKN, UCHKT, URET :
(*null case*);
UCLAB, ULAB, UMST, UNEW, UPLEX, UTJP :
PRINTINT (I1);
UEXPP, UIMPP, UIMPV :
begin
PRINTINT (I1);
PRINTNAM (NAM1);
end;
ULEX : begin
PRINTINT (I1);
PRINTINT (I2);
end;
ULDP : begin
PRINTINT (I1);
PRINTINT (I2);
PRINTNAM (NAM1);
end;
ULOC : begin
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
end;
UEND : PRINTNAM (NAM1);
UBGN, UFJP, UUJP, USTP :
PRINTNAM (NAM1);
UOPTN : begin
PRINTNAM (NAM1);
PRINTINT (I1);
end;
UABS, UADD, USUB, UMPY, UDIV, UAND, UDIF, UDMD, UDSP, UDUP,
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, UIEQU,UINEQ,UIGEQ,UIGRT,
UILEQ,UILES,UINN, UINT, UIOR, UMOD, UMUS, UNEG, UNOT, UODD,
USDEF,USGS, USQR, UUNI :
PRINTTYP (TYP);
UCVT, UCVT2, URND, USWP, UTYP, UTYP2 :
begin
PRINTTYP (TYP);
PRINTTYP (TYPO2);
end;
UDEC, UINC, UIXA, UMOV :
begin
PRINTTYP (TYP);
PRINTINT (I1);
end;
UCHKL, UCHKH :
begin
PRINTTYP (TYP);
if TYP = TYPUC then
PRINTSTRING(SVAL, SLGTH)
else PRINTINT (I1);
end;
UADJ, UICUP, UILOD, UINST, UISTR:
begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTINT (I2);
end;
UENT : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
end;
UDEF : begin
PRINTMTYP (MTYP);
PRINTINT (I1);
end;
UDEAD, UDOA, UEXPV, ULDA, ULIVE, USYM :
begin
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
end;
UMDEF : begin
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
WRITE (OUTPUT, ' ');
PRINTSTRING (SVAL, SLGTH);
end;
UXJP :
begin
PRINTTYP (TYP);
PRINTNAM (NAM1);
PRINTNAM (NAM2);
PRINTINT (I1);
PRINTINT (I2);
end;
ULOD, UNSTR, UPAR, UPLOD, USTR :
begin
PRINTTYP (TYP);
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
end;
UCSP : begin
PRINTTYP (TYP);
PRINTNAM (NAM1);
PRINTINT (I1);
PRINTINT (I2);
end;
UCUP : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTNAM (NAM1);
PRINTINT (I2);
PRINTINT (I3);
end;
ULDC : begin
PRINTTYP (TYP);
PRINTINT (I1);
case TYP of
TYPUI, TYPUK, TYPUM, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
PRINTINT (I2);
TYPUC : PRINTSTRING (SVAL, SLGTH);
TYPUR : WRITE (OUTPUT, ' ', R1);
TYPUN : (*null case*);
TYPUS : PRINTSET (P1);
end (*case TYP of*);
end (*ULDC*);
ULCA : begin
PRINTTYP (TYP);
PRINTINT (I1);
case TYP of
TYPUI, TYPUK, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
PRINTINT (I2);
TYPUC : PRINTSTRING (SVAL, SLGTH);
TYPUR : WRITE (OUTPUT, ' ', R1);
TYPUS : PRINTSET (P1);
TYPUM : PRINTSTRING (SVAL, SLGTH);
end (*case TYP of*);
end (*ULCA*);
UCOMM :
begin
WRITE (OUTPUT,' ');
PRINTSTRING (SVAL, SLGTH);
end ;
UUNK : begin
PRINTINT (I2);
PRINTINT (I3);
WRITE (OUTPUT,' ');
PRINTSTRING (SVAL, SLGTH);
end;
end (*case OPC of*);
WRITELN(OUTPUT);
end (*PRINTNXTINST*);
(** SETREP_PROCESSOR_CLASS: SET_IN SET_DIF SET_INT SET_UNI BUILD_SET *)(*setch*)
(**)
(*X10S1/FULL...*)
function SET_IN(*(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean*);
(* SET_IN performs the function of the set IN operator for the structured
representation of large sets. Its first parameter is the scalar to be
tested for inclusion in the set, which is the second parameter. setch*)
var INDEX : SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE; (*figure which real set to use*)
SET_EL := SET_EL mod HOST_SET_SIZE; (*figure correct offset*)
if SET_EL in PSET[INDEX] then
SET_IN := true
else
SET_IN := false;
end (*SET_IN*);
(* SET_DIF, SET_INT, and SET_UNI perform the functions of set difference,
intersection, and union, respectively, for the structured representation
of large sets. Note that their parameters A, B, and C correspond to the
construct A := B <setop> C . setch*)
procedure SET_DIF(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] - OP2SET[I];
end (*SET_DIF*);
procedure SET_INT(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] * OP2SET[I];
end (*SET_INT*);
procedure SET_UNI(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] + OP2SET[I];
end (*SET_UNI*);
procedure BUILD_SET(var S : SETREP; SET_EL : SET_EL_TYP);
(*Add a scalar to a structured representation of a large set.*) (*setch*)
var INDEX: SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE;
SET_EL := SET_EL mod HOST_SET_SIZE;
S[INDEX] := S[INDEX]+[SET_EL];
end (*BUILD_SET*);
(*...X10S1/FULL*)
"(*X10S1/FULL...*)
function SET_IN(*(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean*);(*setch*)
begin
SET_IN := SET_EL in PSET
end (*SET_IN*);
procedure SET_DIF(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
begin
DESTSET := OP1SET - OP2SET
end (*SET_DIF*);
procedure SET_INT(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
begin
DESTSET := OP1SET * OP2SET
end (*SET_INT*);
procedure SET_UNI(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
begin
DESTSET := OP1SET + OP2SET
end (*SET_UNI*);
procedure BUILD_SET(var S : SETREP; SET_EL : SET_EL_TYP); (*setch*)
begin
S := S + [SET_EL]
end (*BUILD_SET*);
(*...X10S1/FULL*)"
(** S1WORD_PROCESSOR_CLASS: NEWCODEREC GETFIELD GETSIGNEDFIELD PUTFIELD **)
(**)
procedure NEWCODEREC(var X : A_CODEREC);
(*Gets a fresh new CODEREC from the heap.*)
begin
new(X);
X↑.NEXTPTR := nil;
X↑.CODEWORD := ZEROS1WORD
end (*NEWCODEREC*);
function GETFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Returns in the low-order BITLEN bits of the result the unsigned
value of the field of WORD starting at bit number STARTBIT.
For the present, BITLEN must be <= BITS_ON_COMP_MACH - 1.
Bits are numbered from left to right starting at 0.
Note : this routine changes when S1WORDs really exist!*)
var W1, W2 : integer;
FIRSTAFTER : integer;
begin
GETFIELD_CNT := GETFIELD_CNT + 1; (*PTZ*)
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((BITLEN <= BITS_ON_COMP_MACH - 1) and
(0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('GETFIELD 001');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
(*crosses the 'halfword' boundary*)
GETFIELD:=
W1 mod TWOEXP[18-STARTBIT] * TWOEXP[FIRSTAFTER-18]
+ W2 div TWOEXP[36-FIRSTAFTER]
else
(*totally in left halfword*)
GETFIELD := (W1 mod TWOEXP[18-STARTBIT])
div TWOEXP[18-FIRSTAFTER]
else
(*totally in right halfword*)
GETFIELD := (W2 mod TWOEXP[36-STARTBIT])
div TWOEXP[36-FIRSTAFTER];
end (*GETFIELD*);
function GETSIGNEDFIELD (var WORD : S1WORD;
STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Do sign-extend on GETFIELD. BITLEN must be <= BITS_ON_COMP_MACH - 1.*)
var T : integer;
begin
if not ( BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('GETSIGNED001');
T := GETFIELD (WORD, STARTBIT, BITLEN);
if (T>=TWOEXP[BITLEN-1]) and (BITLEN<WORDBITS) then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
GETSIGNEDFIELD := T - TWOEXP[BITLEN]
else
begin
T := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
GETSIGNEDFIELD := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
end
else
GETSIGNEDFIELD := T;
end (*GETSIGNEDFIELD*);
procedure PUTFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH; FIELDVAL : integer);
(*Copies the low order BITLEN bits from FIELDVAL into a field
in WORD starting at bit number STARTBIT. (Bits are numbered
from left to right starting at 0.) High-order bits in FIELDVAL
should be either all ones or all zeros. Note : this routine
changes when S1WORDs really exist! At present assumes that
BITLEN <= BITS_ON_COMP_MACH - 1.*)
var W1, W2 : integer;
P : integer;
FIRSTAFTER : integer;
begin
if not (BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('PUTFIELD 001');
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('PUTFIELD 002');
(*Zero out sign-extend bits of FIELDVAL.*)
if FIELDVAL < 0 then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
FIELDVAL := FIELDVAL + TWOEXP[BITLEN]
else
begin
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
end;
if not (0<=FIELDVAL) then ASSERTFAIL('PUTFIELD 003');
if BITLEN <= MAX_EXP_ON_COMP_MACH then
if not (FIELDVAL < TWOEXP[BITLEN]) then ASSERTFAIL('PUTFIELD 004');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
begin (*crosses 'halfword' boundary*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ FIELDVAL div TWOEXP[FIRSTAFTER-18];
W2 := W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL mod TWOEXP[FIRSTAFTER-18]
* TWOEXP[36-FIRSTAFTER];
end
else
(*entirely in left half*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ W1 mod TWOEXP[18-FIRSTAFTER]
+ FIELDVAL * TWOEXP[18-FIRSTAFTER]
else
(*entirely in right half*)
W2 := W2 - W2 mod TWOEXP[36-STARTBIT]
+ W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL * TWOEXP[36-FIRSTAFTER];
WORD.LHALF := W1;
WORD.RHALF := W2;
end (*PUTFIELD*);
(** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
(**)
(* Comment out the 370 version...
Note that this procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
WARNING: This routine is totally 370 PASCAL dependent;
It will be much simpler in its S-1 version.*"
type TRIT = 0..2;
var NEG : boolean;
EXP : integer;
TOP27, BOT29 : integer;
ICR : record
DUMMY : integer "*alignment*";
case TAG:TRIT of
0: (I: array [1..2] of integer);
1: (C: packed array [1..8] of char);
2: (R: real)
end;
begin
W1 := ZEROS1WORD; W2 := ZEROS1WORD;
ICR.R := XRVAL;
if ICR.R <> 0.0 then
begin
if ICR.R >= 0.0 then NEG := false else
begin ICR.R := -ICR.R; NEG := true end;
EXP := (ord(ICR.C[1]) - 64) * 4;
ICR.C[1] := chr(0);
TOP27 := ICR.I[1]*8 + ord(ICR.C[5]) div 32;
ICR.C[5] := chr(ord(ICR.C[5]) mod 32);
BOT29 := ICR.I[2];
while TOP27 < TWOEXP[26] do "*binary normalize*"
begin
EXP := EXP - 1;
BOT29 := BOT29 * 2;
TOP27 := TOP27 * 2;
if BOT29 >= TWOEXP[29] then
begin
BOT29 := BOT29 - TWOEXP[29];
TOP27 := TOP27 + 1
end
end;
EXP := EXP + 128; "*to excess 128*"
if NEG then "*want twos complement*"
begin
BOT29 := - BOT29;
if BOT29<>0 then TOP27 := TOP27 + 1;
TOP27 := - TOP27;
if (BOT29<>0) or (TOP27<>0) then EXP := EXP + 1;
EXP := - EXP
end;
PUTFIELD(W1,0,9,EXP);
PUTFIELD(W1,9,27,TOP27);
PUTFIELD(W2,0,29,BOT29)
end "*ICR <> 0.0*"
end "*XREAL_TO_S1WORDS*";
...*)
(* The following procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
S-1 VERSION and PDP-10 VERSION (same procedure) *"
var RS10 : record "*for getting (only) word on PDP-10*"
case BIT of
0: (R: real; I: integer);
1: (S: HOST_SET_TYP) "*setch*"
end;
RSH : record "*for getting high order word on S-1*"
case BIT of
0: (I: integer; R: real);
1: (S: HOST_SET_TYP; J: integer) "*setch*"
end;
RSL : record "*for getting low order word on S-1*"
case BIT of
0: (R: real);
1: (S: HOST_SET_TYP) "*setch*"
end;
N : HOST_SET_EL_TYP; "*setch*"
begin
RS10.R := 0.0;
RS10.I := -1;
if 36 in RS10.S then
begin "*PDP-10*"
RS10.R := XRVAL;
RS10.I := 0;
W1 := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS10.S then
PUTFIELD (W1, N, 1, 1);
W2 := ZEROS1WORD;
end "*PDP-10*"
else
begin "*S-1*"
RSH.I := 0;
RSH.R := XRVAL;
W1 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSH.S then
PUTFIELD (W1, WORDBITS-1-N, 1, 1);
RSL.R := XRVAL;
W2 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSL.S then
PUTFIELD (W2, WORDBITS-1-N, 1, 1);
end "*S-1*";
end "*XREAL_TO_S1WORDS*";
...*)
(*procedure S1WORD_TO_REAL(var W : S1WORD; RVAL : real);*) (*23dec78 ALS*)
(*Translates one S1WORD into a real value.*)
procedure REAL_TO_S1WORD(var W : S1WORD; RVAL : real); (*LCW*)
(*Translate a real value into one S1 word.
S-1 VERSION and PDP-10 VERSION (same procedure) *)
type TRIT = 0..2; (*EJG*)
var RS : record (*for getting word on PDP-10 or S-1*)
case TRIT of (*EJG*)
0: (R: real; I: integer);
1: (S: HOST_SET_TYP); (*EJG*) (*setch*)
2: (I2: integer; R2: real) (*EJG*)
end;
N : HOST_SET_EL_TYP; (*setch*)
begin
RS.R := 0.0;
RS.I := -1;
if 36 in RS.S then
begin (*PDP-10*)
RS.R := RVAL;
RS.I := 0;
W := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS.S then
PUTFIELD (W, N, 1, 1);
end (*PDP-10*)
else
begin (*S-1*)
RS.I2 := 0;
RS.R2 := RVAL;
W := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RS.S then
PUTFIELD (W, WORDBITS-1-N, 1, 1);
end (*S-1*);
end (*REAL_TO_S1WORD*);
procedure ZSYMBOL_TO_S1WORDS(var W1, W2 : S1WORD; LSNAM : ALFA);
(*Translate a symbol name into a pair of S1 words.*)
var I, STBIT : integer;
SNAM : ZSYMBOL;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
W1 := ZEROS1WORD;
W2 := ZEROS1WORD;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W1,STBIT,CHARBITS,ord(SNAM[I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W2,STBIT,CHARBITS,ord(SNAM[WORDCHARS+I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end
end (*ZSYMBOL_TO_S1WORDS*);
procedure INTEGER_TO_S1WORD (var W : S1WORD; I : integer);
(*Put the integer I into the S1WORD, sign-extended.*)
begin
W := ZEROS1WORD;
PUTFIELD (W, WORDBITS-(BITS_ON_COMP_MACH-1), BITS_ON_COMP_MACH-1, I);
if I < 0 then
PUTFIELD (W, 0, WORDBITS-(BITS_ON_COMP_MACH-1), -1);
end (*INTEGER_TO_S1WORD*);
procedure SETREP_TO_S1WORDS (var S1SET : S1SETREP; SVAL : SETREP);
(*Translate a set value to the S1's set representation.
Note that SET_MAX = S1SETREP_SIZE*WORDBITS - 1.*)
(*Would it be faster to equivalence a set to integers?*)
var INDEX : S1SETREP_INDEX; (*setch...*)
N, TMP1, TMP2 : SET_EL_TYP;
begin
for INDEX := 0 to S1SETREP_MAX do
begin
S1SET[INDEX] := ZEROS1WORD;
TMP1 := (S1SETREP_MAX + 1 - INDEX)*WORDBITS - 1;
TMP2 := (S1SETREP_MAX - INDEX)*WORDBITS;
for N := TMP1 downto TMP2 do
if SET_IN(N, SVAL) then
PUTFIELD(S1SET[INDEX], TMP1 - N, 1, 1);
end; (*...setch*)
end (*SETREP_TO_S1WORDS*);
(** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVCHR_S1WORD_4 CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
(**)
function LABELHASH (LNUM : LBL_INDEX) : RNG_0_LBLHTSIZEM1;
begin
LABELHASH := ABS(LNUM) mod LBLHTSIZE;
end (*LABELHASH*);
function LABELNUMBER (var NAME : NAMEREC) : LBL_INDEX;
(*Converts a label name into a label number.*)
var I : ALFALEN;
NUM : 0..MAXLBL;
begin
I := 2; (*Skip the initial 'L'.*)
NUM := 0;
while (I<ALFASIZE) and (NAME.NAM[I]<>' ') do
begin
NUM := NUM*10 + ord(NAME.NAM[I]) - ord('0');
I := I + 1;
end;
if NAME.NAM[I] = ' ' then LABELNUMBER := NUM
else LABELNUMBER := NUM*10 + ord(NAME.NAM[I]) - ord('0');
end (*LABELNUMBER*);
function MIN (X, Y : integer) : integer;
begin
if X < Y then MIN := X else MIN := Y;
end (*MIN*);
function MAX (X, Y : integer) : integer;
begin
if X > Y then MAX := X else MAX := Y;
end (*MAX*);
function POWER2 (X : integer) : integer;
(*Return the integer k such that 2**k = X if X is a power of 2.
Otherwise return some k < 0.*)
var COUNT : integer;
begin
if X <= 0 then POWER2 := -999
else if X = 1 then POWER2 := 0
else if ODD(X) then POWER2 := -999
else if X = 2 then POWER2 := 1
else if X = 4 then POWER2 := 2
else if X = 8 then POWER2 := 3
else if X = 16 then POWER2 := 4
else if X = 32 then POWER2 := 5
else
begin
COUNT := 0;
repeat
COUNT := COUNT + 1;
X := X div 2;
until ODD(X) or (X <= 32);
if X = 32 then POWER2 := COUNT + 5
else POWER2 := -999;
end;
end (*POWER2*);
function FLDW(*(NUM : integer) : integer*);
(*Returns the field width required to exactly contain (with no
spaces) the value NUM represented in decimal.*)
var FW : integer;
begin
FW := 0;
if NUM < 0 then
begin
FW := 1;
NUM := abs(NUM)
end;
repeat
NUM := NUM div 10;
FW := FW + 1
until NUM = 0;
FLDW := FW
end (*FLDW*);
procedure CVCHR_S1WORD_4(var ANS : CHAR4; W : S1WORD); (*23DEC78 ALS...*)
(*Converts an S1WORD into a string of 4 characters.*)
var I : 1..4;
begin
for I := 1 to 4 do
ANS[I] := chr(GETFIELD(W, 9*(I - 1), 9) + CHARDIF);(*CHARDIF*)
end(*CVCHR_S1WORD_4*); (*...23DEC78 ALS*)
procedure CVOS_S1WORD_12(var ANS : CHAR12; W : S1WORD);
(*Converts an S1WORD into an octal string of 12 characters.*)
var I : 1..12;
begin
for I := 1 to 12 do
ANS[I] := chr(ord('0') + GETFIELD(W,3*(I-1),3));
I := 1;
while (I < 12) and (ANS[I] = '0') do
begin
ANS[I] := ' ';
I := I + 1
end
end (*CVOS_S1WORD_12*);
procedure CVOS_12(var ANS : CHAR12; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 12 chars.*)
var I : 1..12;
begin
ANS := ' 0';
I := 12;
while K > 0 do
begin
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_12*);
procedure CVOS_10(var ANS : CHAR10; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 10 chars.*)
var I : 1..10;
begin
ANS := ' 0';
I := 10;
while K > 0 do
begin
if not (I>0) then ASSERTFAIL('CVOS_10 001');
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_10*);
(* als should fix this if it becomes a problem...*)
function CSP_HASH (var NAM : ALFA) : integer;
begin
CSP_HASH := (ord(NAM[1])*676 + ord(NAM[2])*26 + ord(NAM[3]))
mod CSPHTSIZE;
end (*CSP_HASH*); (*...als fix*)
function OPC_HASH (var MNEM : CHAR4) : integer;
begin
OPC_HASH := (((ord(MNEM[2])*4 + ord(MNEM[1]))*8 + ord(MNEM[3]))*8
+ord(MNEM[4])*8) mod OPCHTSIZE;
(* OPC_HASH := (ord(MNEM[1])*676 + ord(MNEM[2])*26 + ord(MNEM[3]))
mod OPCHTSIZE; als 16jul79 *)
end (*OPC_HASH*);
function NAME_TO_CSP (var NAME : NAMEREC) : P_STANDARDPROC;
(*Look up the name in a hash table.*)
var H : integer;
begin
H := CSP_HASH (NAME.NAM);
while (CSPHASHTAB[H].CSPNAM <> NAME) and
(CSPHASHTAB[H].CSPNAM.NAM <> ' ') do
H := (H + 1) mod CSPHTSIZE;
if CSPHASHTAB[H].CSPNAM = NAME then
NAME_TO_CSP := CSPHASHTAB[H].CSP
else ERROR (WINVAL_CSP);
end (*NAME_TO_CSP*);
function MNEM_TO_OPC (var MNEM : CHAR4) : U_OPCODE;
(*Look up the mnemonic in a hash table.*)
var H : integer;
begin
H := OPC_HASH (MNEM);
while (OPCHASHTAB[H].OPCNAM <> MNEM) and
(OPCHASHTAB[H].OPCNAM <> ' ') do
H := (H + 1) mod OPCHTSIZE;
if OPCHASHTAB[H].OPCNAM = MNEM then
MNEM_TO_OPC := OPCHASHTAB[H].OPC
else ERROR (WINVAL_OPC);
end (*MNEM_TO_OPC*);
(** INSTRUCTION_PROCESSOR_CLASS:PTR_OPNDXWD S1OPNDS_EQUAL S1OPND_TEMPLOC GETS1OPCODE AFTER_LAST_XWORD JUMPSKIPDEST NEXT_INSTRUCTION AFTER_FAKEOPS AFTER_NONS1LOC_FAKEOPS INVERT_SKIP INVERT_OPCODE **)
(**)
function PTR_OPNDXWD (INSTLOC : A_CODEREC;
SHORTSTARTBIT : S1BITNUM) : A_CODEREC; (*PTZ*)
(*Return a pointer to the CODEREC which contains the extended
word of this instruction corresponding to the OPND specified
by SHORTSTARTBIT, assuming that this is a real S1 instruction.
If no extended OPND, return nil.*)
var INSTOPF : S1OPFORMAT;
XPTR : A_CODEREC;
begin
INSTOPF := OPFORMAT[GETS1OPCODE(INSTLOC)];
if not (INSTOPF<>VFAKEOP) then ASSERTFAIL('PTR_OPNDX001');
if (SHORTSTARTBIT = OPND2_START) and JUMPS_CONCRETIZED
and (INSTOPF = VJOP) and (GETFIELD(INSTLOC↑.CODEWORD,PR_START,PR_LEN) = 1)
then (*Real PR type jump - no OPND2 field*) PTR_OPNDXWD := nil
else
begin
XPTR := INSTLOC;
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN)=1 then
XPTR := XPTR↑.NEXTPTR;
if SHORTSTARTBIT = OPND1_START then (*NOV78 PTZ...*)
if GETFIELD(INSTLOC↑.CODEWORD,OPND1X_START,OPND1X_LEN)=1 then
XPTR := XPTR↑.NEXTPTR
else
XPTR := nil; (*...NOV78 PTZ*)
if XPTR = INSTLOC then
PTR_OPNDXWD := nil
else
PTR_OPNDXWD := XPTR
end
end (*PTR_OPNXWD*);
function S1OPNDS_EQUAL (INST1LOC : A_CODEREC; INST1OPNDSTBIT : S1BITNUM;(*PTZ*)
INST2LOC : A_CODEREC;
INST2OPNDSTBIT : S1BITNUM) : boolean;
(*Return true iff the 2 operands (including extended words) are equal,
assuming that the instructions are real S1 instructions, and also
that we're NOT comparing jump or skip destinations.
This routine does not consider different ways of referring to the same
location as being equal - operands must be IDENTICAL to match*)
var X1PTR, X2PTR : A_CODEREC;
begin
if not (not ((OPFORMAT[GETS1OPCODE(INST1LOC)] = VJOP)
and (INST1OPNDSTBIT = OPND2_START))
and not ((OPFORMAT[GETS1OPCODE(INST2LOC)] = VJOP)
and (INST2OPNDSTBIT = OPND2_START))) then
ASSERTFAIL('S1OPNDS_E001');
if GETFIELD(INST1LOC↑.CODEWORD,INST1OPNDSTBIT,OPND_LEN)
= GETFIELD(INST2LOC↑.CODEWORD,INST2OPNDSTBIT,OPND_LEN) then
begin
X1PTR := PTR_OPNDXWD(INST1LOC,INST1OPNDSTBIT);
X2PTR := PTR_OPNDXWD(INST2LOC,INST2OPNDSTBIT);
if (X1PTR = nil) or (X2PTR = nil) then
S1OPNDS_EQUAL := X1PTR = X2PTR
else
S1OPNDS_EQUAL := X1PTR↑.CODEWORD = X2PTR↑.CODEWORD
end
else
S1OPNDS_EQUAL := false
end (*S1OPNDS_EQUAL*);
function S1OPND_TEMPLOC (INSTLOC : A_CODEREC; (*PTZ*)
SHORTSTARTBIT : S1BITNUM) : integer;
(*Return value >= 0 iff the OPND starting at SHORTSTARTBIT
of the instruction at INSTLOC is a temporary location.
Currently checks only for temp register or
RTA, RTB & returns the register number if the OPND is a
temporary location. Should be changed when temporaries
are allowed to spill onto the stack or elsewhere*)
var OPNDF : MINSHORTOFFSET..MAXSHORTOFFSET;
begin
OPNDF := GETSIGNEDFIELD
(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN);
if (GETFIELD(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN) = 0)
and (GETFIELD
(INSTLOC↑.CODEWORD,SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN) = 0)
and (((S1RTA <= OPNDF) and (OPNDF <= succ(S1RTB)))
or ((MINTMPS1REG <= OPNDF) and (OPNDF <= MAXTMPS1REG))) then
S1OPND_TEMPLOC := OPNDF
else
S1OPND_TEMPLOC := -1
end (*S1OPND_TEMPLOC*);
function GETS1OPCODE (*(INSTLOC : A_CODEREC) : S1OPCODE*);
(*Return the S1OPCODE translation of the hard opcode
in the instruction at INSTLOC.*)
begin
GETS1OPCODE :=
SOFTOPCODE [
GETFIELD
(INSTLOC↑.CODEWORD, OPCODE_START, OPCODE_LEN) ] ;
end (*GETS1OPCODE*);
function AFTER_LAST_XWORD(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return a pointer to the CODEREC which follows the last extended
word of this instruction, assuming that this is a real S1
instruction.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(INSTLOC)] <> VFAKEOP) then
ASSERTFAIL('AFTER_LAS001');
TPTR := INSTLOC↑.NEXTPTR;
if JUMPS_CONCRETIZED and (OPFORMAT[GETS1OPCODE(INSTLOC)] = VJOP)
and (GETFIELD(INSTLOC↑.CODEWORD,PR_START,PR_LEN) = 1) then
(*Real PR type jump - no OPND2 field*)
else
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) =1 then
TPTR := TPTR↑.NEXTPTR;
if GETFIELD(INSTLOC↑.CODEWORD,OPND1X_START,OPND1X_LEN) = 1 then
TPTR := TPTR↑.NEXTPTR;
AFTER_LAST_XWORD := TPTR
end (*AFTER_LAST_XWORD*);
function JUMPSKIPDEST(*(INSTLOC : A_CODEREC) : A_CODEREC*);
(*Return value of jump or skip destination pointer.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(INSTLOC)] in [VJOP,VSOP]) then
ASSERTFAIL('JUMPSKIPD001');
TPTR := AFTER_LAST_XWORD(INSTLOC);
JUMPSKIPDEST := TPTR↑.CODEPTR
end (*JUMPSKIPDEST*);
function NEXT_INSTRUCTION(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return pointer to instruction after the one addressed
by INSTLOC, allowing for extra words to hold jump or
skip destination pointers.*)
var TPTR : A_CODEREC;
S1OPF : S1OPFORMAT;
begin
S1OPF := OPFORMAT[GETS1OPCODE(INSTLOC)];
if S1OPF = VFAKEOP then
NEXT_INSTRUCTION := INSTLOC↑.NEXTPTR
else
begin (*not VFAKEOP*)
TPTR := AFTER_LAST_XWORD(INSTLOC);
if S1OPF in [VSOP,VJOP] then
NEXT_INSTRUCTION := TPTR↑.NEXTPTR
else
NEXT_INSTRUCTION := TPTR
end (*not VFAKEOP*)
end (*NEXT_INSTRUCTION*);
function AFTER_FAKEOPS(INSTLOC : A_CODEREC) : A_CODEREC;
(*Return pointer to first non-FAKEOP instruction
starting at INSTLOC or beyond.*)
var LOOKING : boolean;
begin
LOOKING := true;
while LOOKING do
if INSTLOC = nil then LOOKING := false
else
if OPFORMAT[GETS1OPCODE(INSTLOC)] = VFAKEOP
then INSTLOC := INSTLOC↑.NEXTPTR
else LOOKING := false;
AFTER_FAKEOPS := INSTLOC
end (*AFTER_FAKEOPS*);
function AFTER_NONS1LOC_FAKEOPS(INSTLOC : A_CODEREC) : A_CODEREC; (*7MAR79 PTZ*)
(*Return pointer to either the first real instruction or the first
S1LOC instruction at INSTLOC or beyond*)
var LOOKING : boolean;
S1OPC : S1OPCODE;
begin
LOOKING := true;
while LOOKING do
if INSTLOC = nil then LOOKING := false
else
begin
S1OPC := GETS1OPCODE(INSTLOC);
if (S1OPC = XS1LOC) or (OPFORMAT[S1OPC] <> VFAKEOP) then
LOOKING := false
else
INSTLOC := INSTLOC↑.NEXTPTR
end;
AFTER_NONS1LOC_FAKEOPS := INSTLOC
end (*AFTER_NONS1LOC_FAKEOPS*);
procedure INVERT_SKIP (SKIPLOC : A_CODEREC);
(*Change the skip opcode at SKIPLOC to skip on the
inverse condition.*)
var SKP : S1SKIPDISTANCE;
S1OPC : S1OPCODE;
begin
SKP := GETFIELD (SKIPLOC↑.CODEWORD, SKP_START, SKP_LEN);
S1OPC := INVERSE_SKIP [GETS1OPCODE(SKIPLOC)];
PUTFIELD (SKIPLOC↑.CODEWORD, OPCODE_START, OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD (SKIPLOC↑.CODEWORD, SKP_START, SKP_LEN, SKP);
end (*INVERT_SKIP*);
procedure INVERT_OPCODE (INSTLOC : A_CODEREC); (*7MAR79 PTZ*)
(*Change the instruction at INSTLOC to have the reverse opcode,
i.e. the one so that OP X,Y = REVERSE_OP Y,X*)
var S1OPC : S1OPCODE;
begin
S1OPC := REVERSE_OP[GETS1OPCODE(INSTLOC)];
if not (S1OPC <> XILLEGAL) then
ASSERTFAIL('INVERT_OP001');
PUTFIELD (INSTLOC↑.CODEWORD, OPCODE_START, OPCODE_LEN,
HARDOPCODE[S1OPC])
end (*INVERT_OPCODE*);
(** INSTRUCTION_PROCESSOR_CLASS:DELETE_INSTR INSERT_OPND1 PEEP_LOC_IS_FREE SWAP_OPERANDS INSTR_WORDS PRINTMAINCODE **)
(**)
procedure DELETE_INSTR (PREVPTR, DELPTR : A_CODEREC; (*7MAR79 PTZ*)
var IWDS_REMOVED : integer);
(* Deletes the instruction whose 1st CODEREC is pointed to by DELPTR.
PREVPTR points to the 1st CODEREC of some instruction preceding
the instruction to be deleted (hopefully it's close to DELPTR) *)
var TPTR : A_CODEREC;
T_IWDS : integer;
DELS1OPFORMAT : S1OPFORMAT;
begin
(*first find the CODEREC immediately preceding DELPTR.
This may not be the last CODEREC in the PREVPTR instruction,
because there may be some VFAKEOP instrs between PREVPTR
and DELPTR*)
TPTR := PREVPTR;
while TPTR <> DELPTR do
begin
PREVPTR := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
T_IWDS := 0;
DELS1OPFORMAT := OPFORMAT[GETS1OPCODE(DELPTR)];
TPTR := DELPTR↑.NEXTPTR;
if DELS1OPFORMAT = VFAKEOP then
MAINCODE.NWORDS := MAINCODE.NWORDS - 1
else
begin
T_IWDS := T_IWDS + 1;
if GETFIELD(DELPTR↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 1 then
begin
TPTR := TPTR↑.NEXTPTR;
T_IWDS := T_IWDS + 1
end;
if GETFIELD(DELPTR↑.CODEWORD,OPND1X_START,OPND1X_LEN) = 1 then
begin
TPTR := TPTR↑.NEXTPTR;
T_IWDS := T_IWDS + 1
end;
if (DELS1OPFORMAT = VSOP) or (DELS1OPFORMAT = VJOP) then
begin
TPTR := TPTR↑.NEXTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS - 1
end;
MAINCODE.NWORDS := MAINCODE.NWORDS - T_IWDS
end (*if DELS1OPFORMAT = VFAKEOP then*);
IWDS_REMOVED := IWDS_REMOVED + T_IWDS;
PREVPTR↑.NEXTPTR := TPTR
end (*DELETE_INSTR*);
procedure INSERT_OPND1 (INSTPTR : A_CODEREC; SHORTOPND1 : OPND_INTEGER; (*PTZ*)
OPND1XWDPTR : A_CODEREC; var IWDS_REMOVED : integer);
var TPTR, NEW_OPND1XWDPTR : A_CODEREC;
T_IWDS : integer;
begin
T_IWDS := 0;
TPTR := INSTPTR;
if GETFIELD(INSTPTR↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 1 then
TPTR := TPTR↑.NEXTPTR;
if GETFIELD(INSTPTR↑.CODEWORD,OPND1X_START,OPND1X_LEN) = 1 then
begin (* delete the old OPND1XWD if there is one *)
TPTR↑.NEXTPTR := TPTR↑.NEXTPTR↑.NEXTPTR;
T_IWDS := T_IWDS + 1
end;
PUTFIELD(INSTPTR↑.CODEWORD,OPND1_START,OPND1_LEN,SHORTOPND1);
if OPND1XWDPTR <> nil then
begin (* insert the new OPND1XWD if there is one *)
if not (GETFIELD(INSTPTR↑.CODEWORD,OPND1X_START,OPND1X_LEN)=1) then
ASSERTFAIL('INSOPND1 001');
(*COPY the OPND1 XWD so as not to create loops
in the codestream by ptr rearrangement*)
NEWCODEREC(NEW_OPND1XWDPTR);
NEW_OPND1XWDPTR↑.CODEWORD := OPND1XWDPTR↑.CODEWORD;
NEW_OPND1XWDPTR↑.NEXTPTR := TPTR↑.NEXTPTR;
TPTR↑.NEXTPTR := NEW_OPND1XWDPTR;
T_IWDS := T_IWDS - 1
end;
MAINCODE.NWORDS := MAINCODE.NWORDS - T_IWDS;
IWDS_REMOVED := IWDS_REMOVED + T_IWDS
end (*INSERT_OPND1*);
function PEEP_LOC_IS_FREE (INSTLOC : A_CODEREC;
TMPLOC : integer) : boolean; (*7MAR79 PTZ*)
(*returns true iff the value contained in the location
given by TMPLOC is dead at INSTLOC, i.e. will not be used again.
This currently only applies to temp registers, but could also
apply to register spill locations (when they are implemented)
or other places, if FREEREGs are emitted to track such locations*)
var FOUND, STILL_LOOKING : boolean;
TS1OPC : S1OPCODE;
begin
FOUND := false;
STILL_LOOKING := INSTLOC <> nil;
while STILL_LOOKING and not FOUND do
begin
TS1OPC := GETS1OPCODE(INSTLOC);
if OPFORMAT[TS1OPC] <> VFAKEOP then
(* it's okay to cross S1LOC fakeinstrs here, because
they really belong to the next instr*)
STILL_LOOKING := false
else
begin (* VFAKEOP *)
if TS1OPC = XFREEREG then
begin
if GETFIELD(INSTLOC↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN)
= TMPLOC then
FOUND := true
end;
INSTLOC := INSTLOC↑.NEXTPTR;
STILL_LOOKING := INSTLOC <> nil
end (* VFAKEOP *)
end (*while*);
PEEP_LOC_IS_FREE := FOUND
end (*PEEP_LOC_IS_FREE*);
procedure SWAP_OPERANDS (INSTLOC : A_CODEREC); (*7MAR79 PTZ*)
(*Swaps the 2 operands of the instruction at INSTLOC*)
var OPND1XWDPTR, OPND2XWDPTR : A_CODEREC;
OPND1XWD_TEMP : S1WORD;
OPND1_TEMP : integer;
begin
if not (OPFORMAT[GETS1OPCODE(INSTLOC)] in [VXOP,VTOP]) then
ASSERTFAIL('SWAP_OPER001');
OPND2XWDPTR := PTR_OPNDXWD(INSTLOC,OPND2_START);
if OPND2XWDPTR <> nil then
begin (*swap XWDs if needed*)
OPND1XWDPTR := PTR_OPNDXWD(INSTLOC,OPND1_START);
if OPND1XWDPTR <> nil then
begin
OPND1XWD_TEMP := OPND1XWDPTR↑.CODEWORD;
OPND1XWDPTR↑.CODEWORD := OPND2XWDPTR↑.CODEWORD;
OPND2XWDPTR↑.CODEWORD := OPND1XWD_TEMP
end
end (*swap XWDs if needed*);
OPND1_TEMP := GETFIELD(INSTLOC↑.CODEWORD, OPND1_START, OPND1_LEN);
PUTFIELD(INSTLOC↑.CODEWORD, OPND1_START, OPND1_LEN,
GETFIELD(INSTLOC↑.CODEWORD, OPND2_START, OPND2_LEN));
PUTFIELD(INSTLOC↑.CODEWORD, OPND2_START, OPND2_LEN, OPND1_TEMP)
end (*SWAP_OPERANDS*);
function INSTR_WORDS(INSTLOC : A_CODEREC; INSTPC : integer) : integer;(*PTZ*)
(* Returns the number of WORDS that the instruction beginning at
INSTLOC occupies. During code concretization, INSTPC should be
a good estimate of the PC at the start of the instruction (it is
used to compute the size of jumps). At other times INSTPC can just
be a dummy value. Should not be trusted before S1LOCS_INSERTED is true
(although it will still give the best known estimate) because the
amount of space a given instr is computed to occupy can increase up to that
time due to increases in the number of instrs (fake and otherwise) in
the codestream *) (*28APR79 PTZ*)
var ICW : S1WORD;
TWDS, JMPOFF : integer;
S1OPC : S1OPCODE;
TPC : 0..MAXS1LOC;
JPTR : A_CODEREC;
begin
ICW := INSTLOC↑.CODEWORD;
S1OPC := GETS1OPCODE(INSTLOC);
case OPFORMAT[S1OPC] of
VFAKEOP:
TWDS := 0;
VTOP, VXOP, VSOP:
begin
TWDS := 1;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
TWDS := TWDS + 1; (*extended OPND1*)
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
TWDS := TWDS + 1; (*extended OPND2*)
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
TWDS := 1;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
TWDS := TWDS + 1; (*extended OPND1*)
if JUMPS_CONCRETIZED then
begin
if (GETFIELD(ICW,PR_START,PR_LEN) = 0) and
(GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
TWDS := TWDS + 1
end
else
begin (*jumps not concretized*)
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
TWDS := TWDS + 1; (*extended OPND2*)
JPTR := JUMPSKIPDEST(INSTLOC);
if GETFIELD(ICW,PR_START,PR_LEN) = 1 then
(*force two-word jump: this is in a jump table.
The instruction should be a JMPA so OPND1 won't
be extended. 2-word jump ASSERTed in CONC_PASS3*)
TWDS := 2
else if not S1LOCS_INSERTED and (JPTR <> nil) then
begin (* if S1LOCs haven't been inserted, we can't tell
whether the jump is backward or forward, but assume it
takes the maximum amount of space, i.e. is forward or
long backward *)
if (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 0)
and (MAINCODE.NWORDS > MAXJPROFFSET) then
(*this will work as long as MAINCODE.NWORDS is an upper
bound on the number of words of instructions emitted*)
(*if not already extended OPND2, assume
extended OPND2 (worst case)*)
TWDS := TWDS + 1
end
else if JPTR <> nil then
begin (*normal jump*)
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('INSTR_WOR001');
if BIGJUMPS and
(GETFIELD(ICW,OPND2X_START,OPND2X_LEN)=0) then
begin (*not already extended OPND2,
may not fit PC-relative*)
TPC := GETFIELD(JPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
(*17JAN79 PTZ, was <*) if (TPC <> S1LOCUNDEF) and (TPC <= INSTPC) then
begin (*backward jump*)
JMPOFF := (TPC - INSTPC) div WORDUNITS;
if JMPOFF < MINJPROFFSET then
(*won't fit PC-relative, assume extended OPND2*)
TWDS := TWDS + 1
end (*backward jump*)
else
begin (*forward jump: can't rely on previous
estimate because no way to communicate decision
to CONC_PASS3 for inserting NOP purposes -
assume extended OPND2 (worst case)*)
TWDS := TWDS + 1
end (*forward jump*)
end (*not already extended OPND2*)
end (*normal jump*)
end (*jumps not concretized*)
end (*VJOP*)
end (*case*);
INSTR_WORDS := TWDS
end (*INSTR_WORDS*);
procedure PRINTMAINCODE; (*28APR79 PTZ*)
(* prints out the contents of the codestream*)
var DEBUGPC, TDEBUGPC : 0..MAXS1LOC;
IPTR : A_CODEREC;
begin
IPTR := MAINCODE.FIRST;
DEBUGPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
TDEBUGPC := DEBUGPC; (*DISASSEMBLE changes its first param*)
(* if (DEBUGPC > 9500) and (DEBUGPC < 10500) then "for large files"*)
DISASSEMBLE(TDEBUGPC,IPTR);
DEBUGPC := DEBUGPC + INSTR_WORDS(IPTR,DEBUGPC)*WORDUNITS;
IPTR := NEXT_INSTRUCTION(IPTR);
end;
end (*PEEP_DEBUG*);
(** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 **)
(**)
procedure FIXSOP(SKIPLOC, SKIPDEST : A_CODEREC);
(*Set the destination pointer following the skip instruction to
point where SKIPDEST points.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(SKIPLOC)] = VSOP) then
ASSERTFAIL('FIXSOP 001');
TPTR := AFTER_LAST_XWORD(SKIPLOC);
TPTR↑.CODEPTR := SKIPDEST
end (*FIXSOP*);
procedure FIXJOP(JUMPLOC, JUMPDEST : A_CODEREC);
(*Set the destination pointer following the jump instruction to
point where JUMPDEST points.*)
var TPTR : A_CODEREC;
begin
if not (OPFORMAT[GETS1OPCODE(JUMPLOC)] = VJOP) then
ASSERTFAIL('FIXJOP 001');
TPTR := AFTER_LAST_XWORD(JUMPLOC);
TPTR↑.CODEPTR := JUMPDEST
end (*FIXJOP*);
procedure FIXOPND2 (INSTLOC : A_CODEREC; FIXVAL : integer);
(*Fixes the extended OPND2 field of the instruction by adding
FIXVAL to the appropriate part of it.The operand may be an
extended constant, a fixed-base address, or a variable-base
address.*)
var W : S1WORD;
CARRY : BIT;
T : integer;
UNKNOWN_LOC : integer;
begin
if not (GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 1) then
ASSERTFAIL('FIXOPND2 001');
if (GETFIELD(INSTLOC↑.CODEWORD,
OPND2REG_START, OPND2REG_LEN) = 1) and
(GETFIELD(INSTLOC↑.CODEWORD,
OPND2F_START, OPND2F_LEN) > 0) then
begin (*extended constant*)
(*Note : this section will be easier with real S1WORDs.*)
INTEGER_TO_S1WORD (W, FIXVAL);
with INSTLOC↑.NEXTPTR↑ do
begin
CARRY := 0;
T := CODEWORD.RHALF + W.RHALF;
if T < TWOEXP[18] then CODEWORD.RHALF := T
else
begin CARRY := 1;
CODEWORD.RHALF := T - TWOEXP[18];
end;
T := CODEWORD.LHALF + W.LHALF + CARRY;
CODEWORD.LHALF := T mod TWOEXP[18];
end;
end (*extended constant*)
else
with INSTLOC↑.NEXTPTR↑ do
if GETFIELD(CODEWORD, XWV_START, XWV_LEN) = 0 then
begin (*fixed-base address*)
T := FIXVAL +
GETSIGNEDFIELD(CODEWORD, XWADDR_START, XWADDR_LEN);
if (T<MINSIGNEDS1ADDR) or (T>MAXSIGNEDS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
PUTFIELD (CODEWORD, XWADDR_START, XWADDR_LEN, T);
end (*fixed-base address*)
else
begin (*variable-base address*)
T := FIXVAL +
GETSIGNEDFIELD(CODEWORD, XWDISP_START, XWDISP_LEN);
if (T<MINS1DISP) or (T>MAXS1DISP) then
ERROR (WDISP_OUT_OF_RANGE);
(*probable cause: data area too large*)
PUTFIELD (CODEWORD, XWDISP_START, XWDISP_LEN, T);
end (*variable-base address*);
if TR_S1CODE then
begin
WRITELN (OUTPUT,
' Fixup performed to produce the instruction:');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, INSTLOC);
end;
end (*FIXOPND2*);
(** FIXUP_CLASS: ADD_CODEPTR_TO_CODELIST ADD_JUMPLIST_PLUS_ONE ADD_JUMP_TO_JUMPLIST JUMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
(**)
procedure UPD_LBLTBL (var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LCODEPTR);
forward;
procedure ADD_CODEPTR_TO_CODELIST(var CL : CODELIST;
XCODEPTR : A_CODEREC);
(*Appends a new CODEREC to the front of codelist CL, containing
pointer XCODEPTR. Obtains a new CODEREC, but does not use
NEWINSTREC.*)
var X : A_CODEREC;
begin
NEWCODEREC(X);
X↑.CODEPTR := XCODEPTR;
X↑.NEXTPTR := CL.FIRST;
if CL.FIRST = nil then CL.LAST := X;
CL.FIRST := X;
CL.NWORDS := 1 + CL.NWORDS
end (*ADD_CODEPTR_TO_CODELIST*);
procedure ADD_JUMPLIST_PLUS_ONE(var JL1, JL2 : JUMPLIST;
JUMPLOC : A_CODEREC);
(*Appends JL2 onto JL1, and also appends the single jump at JUMPLOC
in FRONT of JL1.*)
begin
FIXJOP(JUMPLOC,JL1.FIRST);
if JL1.FIRST = nil then JL1.LAST := JUMPLOC;
JL1.FIRST := JUMPLOC;
FIXJOP(JL1.LAST,JL2.FIRST);
if JL2.FIRST <> nil then JL1.LAST := JL2.LAST;
JL1.NWORDS := 1 + JL1.NWORDS + JL2.NWORDS
end (*ADD_JUMPLIST_PLUS_ONE*);
procedure ADD_JUMP_TO_JUMPLIST(var JL : JUMPLIST;
JUMPLOC : A_CODEREC);
(*Appends the single jump at JUMPLOC onto the front of JL.*)
begin
if not (OPFORMAT[GETS1OPCODE(JUMPLOC)] = VJOP) then (*PEG*)
ASSERTFAIL('ADD_JUMP_001'); (*PEG*)
FIXJOP(JUMPLOC,JL.FIRST);
if JL.FIRST = nil then JL.LAST := JUMPLOC;
JL.FIRST := JUMPLOC;
JL.NWORDS := 1 + JL.NWORDS
end (*ADD_JUMP_TO_JUMPLIST*);
procedure JUMP_TO_TABLE_RECORD_OR_FIX(JUMPLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the jump in the fixup list for this label number or else
fixes it immediately. Also flags label table entry as a
jumptable label and flags the jumps in the table if the table
already exists.*)
var LPTR : A_LBLHASHENT; PTR : A_CODEREC;
begin
UPD_LBLTBL(LPTR,LNUM,LCODEPTR);
with LPTR↑ do
begin
if not DEFINED then
ADD_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
else
begin (*DEFINED*)
FIXJOP(JUMPLOC,CODEPTR);
if not JUMPTABLELABEL then
begin
PTR := CODEPTR;
while (GETS1OPCODE(PTR) = XJMPA) and
(GETFIELD(PTR↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 0)
do
begin
PUTFIELD(PTR↑.CODEWORD,PR_START,PR_LEN,1);
PTR := NEXT_INSTRUCTION(PTR)
end
end (*not JUMPTABLELABEL*)
end (*DEFINED*);
JUMPTABLELABEL := true
end (*with LPTR↑ do*)
end (*JUMP_TO_TABLE_RECORD_OR_FIX*);
procedure JUMP_TO_LABEL_RECORD_OR_FIX(JUMPLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the jump in the fixup list or fixes it immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LCODEPTR);
with LPTR↑ do
if DEFINED then
FIXJOP(JUMPLOC,CODEPTR)
else
ADD_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
end (*JUMP_TO_LABEL_RECORD_OR_FIX*);
procedure OPND2_RECORD_OR_FIX(INSTLOC : A_CODEREC;
LNUM : LBL_INDEX);
(*Records the instruction in the LINTVAL fixup list or fixes it
up immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LINTVAL);
with LPTR↑ do
if DEFINED then
FIXOPND2(INSTLOC,INTVAL)
else
ADD_CODEPTR_TO_CODELIST(CLIST,INSTLOC)
end (*OPND2_RECORD_OR_FIX*);
(** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_REG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
(**)
function FITS_SHRT_OFFSET (DISP : S1DISP) : boolean;
forward;
function ISREG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand.*)
begin
ISREG := (OPND.X=0) and (OPND.REG=0);
end (*ISREG*);
function IS_T_REG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (including RTA, RTB),
as opposed to a parm or display register.*)
begin
IS_T_REG := (OPND.X=0) and (OPND.REG=0)
and (((S1RTA<=OPND.F) and (OPND.F<=succ(S1RTB)))
or ((MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG)));
end (*IS_T_REG*);
function IS_T_REG_NOT_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (excluding RTB and RTA),
as opposed to a parm or display register.*)
begin
IS_T_REG_NOT_RT := (OPND.X=0) and (OPND.REG=0)
and (MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG);
end (*IS_T_REG_NOT_RT*);
function ISSHORTCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a short-constant operand.*)
begin
ISSHORTCONST := (OPND.X=0) and (OPND.REG=1);
end (*ISSHORTCONST*);
function ISCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a constant operand.*)
(*Note - this procedure is never used, but could be.*)
begin
ISCONST := ( (OPND.X=0) and (OPND.REG=1) )
or ( (OPND.X=1) and (OPND.REG=1) and (OPND.F<>0) );
end (*ISCONST*);
function EQUAL_OPERANDS (var X, Y : OPERAND) : boolean;
(*Return true iff two operands are equal in all fields.*)
var EQSOFAR : boolean;
begin
EQSOFAR :=
(X.X = Y.X)
and (X.REG = Y.REG)
and (X.F = Y.F)
and (X.FIXUP = Y.FIXUP)
and (X.FIXPTR = Y.FIXPTR)
and (X.XW.FMT = Y.XW.FMT);
if EQSOFAR then
case X.XW.FMT of
XW_EV :
EQSOFAR :=
(X.XW.P = Y.XW.P)
and (X.XW.V = Y.XW.V)
and (X.XW.D = Y.XW.D)
and (X.XW.I = Y.XW.I)
and (X.XW.S = Y.XW.S)
and (X.XW.ADDR = Y.XW.ADDR)
and (X.XW.REG = Y.XW.REG)
and (X.XW.DISP = Y.XW.DISP);
XW_C :
EQSOFAR :=
(X.XW.VAL = Y.XW.VAL)
end (*case*);
EQUAL_OPERANDS := EQSOFAR
end (*EQUAL_OPERANDS*);
procedure REG_OPERAND (var OPND : OPERAND; R : S1REGISTER);
(*Build an operand specifying register R.*)
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := 0;
OPND.F := ord(R);
end (*REG_OPERAND*);
procedure IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an operand which specifies a constant integer value VAL.*)
begin
if (MINSHORTCONSTANT <= VAL) and (VAL <= MAXSHORTCONSTANT) then
begin
OPND := ZERO_OP;
if not (OPND.REG=1) then ASSERTFAIL('IMM_OPERA001');
OPND.F := VAL
end
else
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end;
end (*IMM_OPERAND*);
procedure REAL_IMM_OPERAND (var OPND : OPERAND; RVAL : real); (*LCW*)
(*Build an operand which specifies a constant real value VAL.*)
begin
if RVAL = 0.0 then
OPND := ZERO_OP
else
begin
OPND := EXTENDED_ZERO_OP;
REAL_TO_S1WORD (OPND.XW.VAL, RVAL);
end;
end (*REAL_IMM_OPERAND*);
function IS_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA or RTB.*)
(*Note - this procedure is never used.*)
begin
IS_RT := (OPND.X=0) and (OPND.REG=0)
and ( (OPND.F=ord(S1RTA)) or (OPND.F=ord(S1RTB)) );
end (*IS_RT*);
function IS_RTA (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA.*)
begin
IS_RTA := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTA));
end (*IS_RTA*);
function IS_RTB (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTB.*)
begin
IS_RTB := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTB));
end (*IS_RTB*);
function USES_RTA(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTA.*)
begin
if (OPND.REG = S1RTA) or
(OPND.REG = 0) and (OPND.F = ord(S1RTA)) then
USES_RTA := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTA := false
else USES_RTA := (OPND.XW.V=1) and (OPND.XW.REG=S1RTA);
end (*USES_RTA*);
function USES_RTB(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTB.*)
begin
if (OPND.REG = S1RTB) or
(OPND.REG = 0) and (OPND.F = ord(S1RTB)) then
USES_RTB := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTB := false
else USES_RTB := (OPND.XW.V=1) and (OPND.XW.REG=S1RTB);
end (*USES_RTB*);
(** OPERAND_PROCESSOR_CLASS: EXTENDED_IMM_OPERAND REGDISP_OPERAND EXTENDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND TWIDDLE_OPERAND **)
(**)
procedure EXTENDED_IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an extended operand which specifies
the integer constant VAL.*)
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end (*EXTENDED_IMM_OPERAND*);
procedure REGDISP_OPERAND (var OPND : OPERAND;
REG : S1REGISTER; DISP : S1DISP);
(*Build an operand specifying the address DISP(%REG). *)
begin
if FITS_SHRT_OFFSET(DISP) then
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := ord(REG);
OPND.F := DISP div WORDUNITS;
end
else
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end;
end (*REGDISP_OPERAND*);
procedure EXTENDED_REGDISP_OPERAND
(var OPND : OPERAND; REG : S1REGISTER; DISP : S1DISP);
(*Build an extended operand specifying the address DISP(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end (*EXTENDED_REGDISP_OPERAND*);
procedure EXT_REGADDR_OPERAND (*EJG*)
(var OPND : OPERAND; REG : S1REGISTER; ADDR : S1ADDRESS);
(*Build an extended operand specifying the address ADDR(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 0;
OPND.F := ord(REG);
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*EXT_REGADDR_OPERAND*);
procedure ADDR_OPERAND (var OPND : OPERAND; ADDR : S1ADDRESS);
(*Build an operand which specifies the absolute address ADDR.*)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*ADDR_OPERAND*);
procedure TWIDDLE_OPERAND (var OPND : OPERAND; TWIDDLE : integer);
(*Change OPND to specify a location TWIDDLE quarterwords
from where it does now, if that is possible.*)(*peg 16MAY79*)
begin
if TWIDDLE <> 0 then
if ISREG(OPND) then
if not (TWIDDLE mod WORDUNITS = 0) then ASSERTFAIL('TWIDDLE_O001')
else if not ((ord(FIRSTS1REG) <= OPND.F + (TWIDDLE div WORDUNITS))
and (OPND.F + (TWIDDLE div WORDUNITS) <= ord(LASTS1REG)))
then ASSERTFAIL('TWIDDLE_O002')
else OPND.F := OPND.F + (TWIDDLE div WORDUNITS)
else if (OPND.X = 0) (*Short-indexed*)
and ((ord(S1RPC) <= OPND.REG) and (OPND.REG <= ord(LASTS1REG))) then
if FITS_SHRT_OFFSET(OPND.F*WORDUNITS + TWIDDLE) then
OPND.F := OPND.F + (TWIDDLE div WORDUNITS)
else
begin (*Convert to extended*)
OPND.X := 1;
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := OPND.REG;
OPND.XW.DISP := OPND.F*WORDUNITS + TWIDDLE;
OPND.REG := 1;
OPND.F := 0;
end (*Convert to extended*)
else if (OPND.X = 1) and (OPND.XW.I <> 1) then (*Extended addressing*)
begin
if OPND.XW.V = 0 then (*Fixed-based*)
OPND.XW.ADDR := OPND.XW.ADDR + TWIDDLE
else if OPND.XW.V = 1 then (*Variable-based*)
OPND.XW.DISP := OPND.XW.DISP + TWIDDLE
end (*Extended addressing*)
else if not (false) then ASSERTFAIL('TWIDDLE_O003'); (*All others*)
end (*TWIDDLE_OPERAND*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLAREFREE ALLOCRG ALLOCRP FREERG_S FINDRGBLOCK FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
(**)
procedure EMITFAKEINST(FAKEOPC : S1OPCODE; FAKEOPND : integer); (*PBK*)
forward;
procedure EMITXOP (S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND);
forward;
procedure ALLOCGBL (G : S1GBL);
(*Allocates a global (ie. low-core memory word) G.*)
begin
if not (GISFREE[G]) then ASSERTFAIL('ALLOCGBL 001');
GISFREE[G] := false;
end (*ALLOCGBL*);
procedure FREEGBL_S (G : S1GBL);
(*Frees a global or global pair starting with word G.
The name FREEGBL_S is intended to suggest FREEGBL(S). *)
begin
if not ( not GISFREE[G]) then ASSERTFAIL('FREEGBL_S001');
GISFREE[G] := true;
end (*FREEGBL_S*);
function ALLAREFREE(FIRSTRG, SIZE : S1REGISTER) : boolean; (*PEG 14MAY79...*)
(*Checks to see if all registers in the block starting at FIRSTRG of
length SIZE are free.*)
var FREE : boolean;
I : S1REGISTER;
begin
FREE := RISFREE[FIRSTRG];
I := FIRSTRG + 1;
while FREE and (I <= FIRSTRG + SIZE - 1) do
begin
FREE := (*FREE and*) RISFREE[I];
I := I + 1;
end;
ALLAREFREE := FREE;
end (*ALLAREFREE*); (*...PEG 14MAY79*)
procedure ALLOCRG (R : S1REGISTER);
begin
if not (RISFREE[R]) then ASSERTFAIL('ALLOCRG 001');
RISFREE[R] := false;
RPWORD[R] := RSINGLE; (*PBK*)
end (*ALLOCRG*);
procedure ALLOCRP (R : S1REGISTER);
begin
if not ( RISFREE[R] and RISFREE[succ(R)] ) then ASSERTFAIL('ALLOCRP 001');
RISFREE[R] := false;
RISFREE[succ(R)] := false;
RPWORD[R] := R1STOFPAIR; (*PBK*)
RPWORD[succ(R)] := R2NDOFPAIR; (*PBK*)
end (*ALLOCRP*);
procedure FREERG_S(R : S1REGISTER);
(*Frees a register or register pair starting with R.
The name FREERG_S is intended to suggest FREERG(S). *)
begin
if (RISFREE[R]) or (RPWORD[R] = R2NDOFPAIR)
or (RPWORD[R] = RINBLOCK) then (*PEG*)
ASSERTFAIL('FREERG_S 001'); (*PBK*)
RISFREE[R] := true;
EMITFAKEINST(XFREEREG,R); (*PBK*)
if RPWORD[R] = R1STOFPAIR then (*PBK*)
begin
RISFREE[R+1] := true;
EMITFAKEINST(XFREEREG,R+1) (*PBK*)
end (* if RPWORD[R] = R1STOFPAIR then *) (*PBK*)
else if RPWORD[R] = R1STOFBLOCK then (*PEG 14MAY79...*)
begin
R := R + 1;
while RPWORD[R] = RINBLOCK do
begin
RISFREE[R] := true;
EMITFAKEINST(XFREEREG,R);
R := R + 1;
end;
end (*if RPWORD[R] = R1STOFBLOCK*); (*...PEG 14MAY79*)
end (*FREERG_S*);
procedure FINDRGBLOCK(SIZE : S1REGISTER); (*PEG 14MAY79...*)
(*Find and allocate a block of temporary registers (Not RTA or RTB) of
length SIZE. Return the smallest reg number in global variable NXTRG.*)
(* NOTE: THIS IS A TEMPORARY VERSION OF THIS ROUTINE. EVENTUALLY IT
WILL BE MUCH SMARTER, or replaced by calls to the runtime-stack temp
routines which are yet to be written. PEG. *)
var I : S1REGISTER;
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG - SIZE)
and not ALLAREFREE(NXTRG, SIZE) do
NXTRG := NXTRG + 1;
if ALLAREFREE(NXTRG, SIZE) then
begin
RISFREE[NXTRG] := false;
RPWORD[NXTRG] := R1STOFBLOCK;
for I := (NXTRG + 1) to (NXTRG + SIZE - 1) do
begin
RISFREE[I] := false;
RPWORD[I] := RINBLOCK;
end;
if (NXTRG + SIZE - 1) > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG + SIZE - 1;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end
else ERROR(WEXPR_TOO_COMPLEX)
end (*FINDRGBLOCK*); (*...PEG 14MAY79*)
procedure FINDRP;
(*Find and allocate a pair of temporary registers (Not RTA or RTB).
Return the smaller reg number in global variable NXTRG.*)
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-2)
and not (RISFREE[NXTRG] and RISFREE[NXTRG+1]) do
NXTRG := NXTRG + 1;
if RISFREE[NXTRG] and RISFREE[NXTRG+1] then
begin
RISFREE[NXTRG] := false;
RISFREE[NXTRG+1] := false;
RPWORD[NXTRG] := R1STOFPAIR; (*PBK*)
RPWORD[NXTRG+1] := R2NDOFPAIR; (*PBK*)
if NXTRG+1 > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG+1;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end
else ERROR(WEXPR_TOO_COMPLEX)
end (*FINDRP*);
procedure FINDRG;
(*Find and allocate one of the temporary registers (Not RTA or
RTB), trying not to split potential pairs. Return reg number in
global variable NXTRG.*)
var I, ISAVE : S1REGISTER;
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-1) and not RISFREE[NXTRG] do
NXTRG := NXTRG + 1;
if not RISFREE[NXTRG] then
ERROR(WEXPR_TOO_COMPLEX)
else (*Found a free one (NXTRG). Can we improve on it?*)
begin
I := NXTRG;
while I <= MAXTMPS1REG do
begin
ISAVE := I;
repeat I := I + 1 until (I>MAXTMPS1REG) or not RISFREE[I];
if I-ISAVE = 1 then (*I-ISAVE = num of adjacent free regs*)
begin (*found an isolated free reg: use it*)
NXTRG := ISAVE;
I := MAXTMPS1REG + 1
end
else (*skip over next group of adjacent nonfree regs*)
while (I<=MAXTMPS1REG) and not RISFREE[I] do I := I + 1
end (*while I<=MAXTMPS1REG do*);
RISFREE[NXTRG] := false;
RPWORD[NXTRG] := RSINGLE; (*PBK*)
if NXTRG > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end (*Found a free one*)
end (*FINDRG*);
procedure MOVE_AND_FREE_RTB;
(*We free RTB to use it to return function values or to
pass parameters to standard procs.
WARNING!!! This should not be called if an operand has
been built since it could invalidate the operand.*)
var MOVEOP : S1OPCODE;
OPNDR : OPERAND;
begin
if not (not RISFREE[S1RTB]) then ASSERTFAIL('MOVE_AND_001');
if RTBDOUB then
begin FINDRP; MOVEOP := XMOV_D_D end
else
begin FINDRG; MOVEOP := XMOV_S_S end;
REG_OPERAND(OPNDR,NXTRG);
EMITXOP(MOVEOP,OPNDR,OPNDRTB);
if not (RTBUSER <= TOP) then ASSERTFAIL('MOVE_AND_002');
with STK[RTBUSER] do
begin (*Update RTB datum to point to new reg*)
if FPA.WHICH = RGS then if FPA.RGADR = S1RTB then
FPA.RGADR := NXTRG;
if VPA1.VPA.WHICH = RGS then if VPA1.VPA.RGADR = S1RTB then
VPA1.VPA.RGADR := NXTRG;
if VPA2.VPA.WHICH = RGS then if VPA2.VPA.RGADR = S1RTB then
VPA2.VPA.RGADR := NXTRG
end;
FREERG_S(S1RTB)
end (*MOVE_AND_FREE_RTB*);
function CURRENT_PARMREG_COUNT : NUMBER_OF_PAREGS;
(*Returns the current number of parameter registers.*)
begin
CURRENT_PARMREG_COUNT := MINTMPS1REG - MINPARS1REG
end (*CURRENT_PARMREG_COUNT*);
function IS_PARMREG (R : S1REGISTER) : boolean;
(*Returns true iff R is a parameter register.*)
begin
IS_PARMREG := (MINPARS1REG<=R) and (R<MINTMPS1REG);
end (*IS_PARMREG*);
procedure CHECK_DSP_TMP_COLLISION;
(*Checks to see if there is a collision between the display
registers and the temporary registers. If so, an error message
is given; this is a non-recoverable situation requiring the user
to either simplify expressions or un-nest procedures.*)
begin
if MINDSPS1REG <= MAXTMPS1REG then
ERROR(WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX)
end (*CHECK_DSP_TMP_COLLISION*);
procedure RESERVE_PARMREGS(COUNT : NUMBER_OF_PAREGS);
(*Changes the reservation to a given number of the parameter
registers, after asserting that any newly reserved ones are
available.*)
var I : S1REGISTER;
begin
for I := MINTMPS1REG to MINPARS1REG+COUNT-1 do
if not (RISFREE[I]) then ASSERTFAIL('RESERVE_P001');
MINTMPS1REG := MINPARS1REG + COUNT;
MAXTMPS1REG := MAX(MAXTMPS1REG,MINTMPS1REG-1);
CHECK_DSP_TMP_COLLISION
end (*RESERVE_PARMREGS*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREEVPARGUNLESS FREE_TEMP_REGS **)
(**)
procedure FREEDATUMREGS (STE : STKINX);
(*Free all the temp expr regs (not display or parm regs)
used in the datum. Does *not* change the datum.*)
begin
if (STK[STE].FPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end (*FREEDATUMREGS*);
procedure FREEREGSBUTTHESE (STE : STKINX; REGS : SETOFS1REGS);
(*Free all the temp expr regs used in the datum,
*except* do not free registers in REGS if used.*)(*PEG*)
begin
with STK[STE] do
begin
if (FPA.WHICH=RGS) then
if not (FPA.RGADR in REGS) then
if (MINTMPS1REG<=FPA.RGADR) and
(FPA.RGADR<=MAXTMPS1REG) or
(FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (FPA.RGADR);
if NVPAS >= 1 then
if (VPA1.VPA.WHICH=RGS) then
if not (VPA1.VPA.RGADR in REGS) then
if (MINTMPS1REG<=VPA1.VPA.RGADR) and
(VPA1.VPA.RGADR<=MAXTMPS1REG) or
(VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(VPA1.VPA.RGADR);
if NVPAS = 2 then
if (VPA2.VPA.WHICH=RGS) then
if not (VPA2.VPA.RGADR in REGS) then
if (MINTMPS1REG<=VPA2.VPA.RGADR) and
(VPA2.VPA.RGADR<=MAXTMPS1REG) or
(VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (VPA2.VPA.RGADR);
end (*with STK[STE]*)
end (*FREEREGSBUTTHESE*);
(*NOTE - This procedure is never used. If it is used in the future, it
should be carefully checked for discrepencies (in other words,
it is not guaranteed to have been maintained)....
procedure FREERGSBUTSOME (STE, STE2 : STKINX);
%*Free all temp expr regs used in STK[STE], *except*
do not free any used in STK[STE2]. *\
var DONTFREE : set of S1REGISTER;
begin
DONTFREE := [ ];
if STK[STE].FPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].FPA.RGADR];
if STK[STE].VPA1.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA1.VPA.RGADR];
if STK[STE].VPA2.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA2.VPA.RGADR];
if (STK[STE].FPA.WHICH=RGS) then
if not (STK[STE].FPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if not (STK[STE].VPA1.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if not (STK[STE].VPA2.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end %*FREERGSBUTSOME*\;
...end of unused procedure.*)
procedure FREEVPAREG (var V : VPAREC);
(*Free the temp expr reg used in V, if any. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREEVPAREG*);
procedure FREEVPARGUNLESS (var V : VPAREC; R : S1REGISTER);
(*Free the temp expr reg used in V, if any, *EXCEPT* does
not free R if used. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if V.VPA.RGADR <> R then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREEVPARGUNLESS*);
procedure FREE_TEMP_REGS;
(*Release all the temp expr regs, including RTA and RTB.*)
var R : S1REGISTER;
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
for R := MINTMPS1REG to MAXTMPS1REG do
if not RISFREE[R] then FREERG_S (R);
end (*FREETEMPREGS*);
(** CODE_EMITTER_CLASS: BUILD_CW_OPERAND EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
(**)
procedure BUILD_CW_OPERAND(var SHORTWORD : S1WORD;
XWORDPTR : A_CODEREC;
var OPND : OPERAND;
SHORTSTARTBIT : S1BITNUM);
(*Build an S1 operand from OPND in SHORTWORD and XWORDPTR↑.
Position the first bit of the short part at bit SHORTSTARTBIT in
SHORTWORD; leave other 24 bits alone. Add the extended word to a
fixup list if necessary.*)
begin
PUTFIELD(SHORTWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN,OPND.X);
PUTFIELD(SHORTWORD,
SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN,OPND.REG);
PUTFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN,OPND.F);
if OPND.FIXUP <> NOFIX then
begin
if not (OPND.X = 1) then ASSERTFAIL('BUILD_CW_001');
case OPND.FIXUP of
STRINGFIX: ADD_CODEPTR_TO_CODELIST(STRINGFIXLIST,XWORDPTR);
SETFIX: ADD_CODEPTR_TO_CODELIST(SETFIXLIST,XWORDPTR);
REALFIX: ADD_CODEPTR_TO_CODELIST(REALFIXLIST,XWORDPTR);
BOUNDFIX: ADD_CODEPTR_TO_CODELIST(BOUNDFIXLIST,XWORDPTR);
XTRNSYMFIX: ADD_CODEPTR_TO_CODELIST(OPND.FIXPTR↑.FIXLIST,
XWORDPTR)
end (*case*)
end (*if OPND.FIXUP <> NOFIX*);
if OPND.X = 1 then
begin (*extended word*)
if OPND.XW.FMT = XW_C then
begin
if not ((OPND.F > 0) and (OPND.REG = 1)) then
ASSERTFAIL('BUILD_CW_002');
XWORDPTR↑.CODEWORD := OPND.XW.VAL
end
else (*extended address*)
begin
if not (not ((OPND.F > 0) and (OPND.REG = 1))) then
ASSERTFAIL('BUILD_CW_003');
PUTFIELD(XWORDPTR↑.CODEWORD,XWP_START,XWP_LEN,OPND.XW.P);
PUTFIELD(XWORDPTR↑.CODEWORD,XWV_START,XWV_LEN,OPND.XW.V);
PUTFIELD(XWORDPTR↑.CODEWORD,XWD_START,XWD_LEN,OPND.XW.D);
PUTFIELD(XWORDPTR↑.CODEWORD,XWI_START,XWI_LEN,OPND.XW.I);
PUTFIELD(XWORDPTR↑.CODEWORD,XWS_START,XWS_LEN,OPND.XW.S);
if OPND.XW.V = 0 then
PUTFIELD(XWORDPTR↑.CODEWORD,
XWADDR_START,XWADDR_LEN,OPND.XW.ADDR)
else
begin
PUTFIELD(XWORDPTR↑.CODEWORD,
XWREG_START,XWREG_LEN,OPND.XW.REG);
PUTFIELD(XWORDPTR↑.CODEWORD,
XWDISP_START,XWDISP_LEN,OPND.XW.DISP)
end
end (*extended address*)
end (*extended word*)
end (*BUILD_CW_OPERAND*);
procedure EMIT_INSTR_OPNDS(var OPND1, OPND2 : OPERAND);
(*Common to EMIT routines. Fill in the short operand fields (at
NEWINSTREC), emit the instr. record, and allocate and emit
extended words if needed. Update MAINCODE to reflect
insertions.*)
var TPTR : A_CODEREC;
begin
if MAINCODE.FIRST = nil then MAINCODE.FIRST := NEWINSTREC
else MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
MAINCODE.LAST := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR);
BUILD_CW_OPERAND(NEWINSTREC↑.CODEWORD,TPTR,OPND2,OPND2_START);
if OPND2.X = 1 then
begin (*extended OPND2*)
MAINCODE.LAST↑.NEXTPTR := TPTR;
MAINCODE.LAST := TPTR;
TPTR↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR)
end;
BUILD_CW_OPERAND(NEWINSTREC↑.CODEWORD,TPTR,OPND1,OPND1_START);
if OPND1.X = 1 then
begin (*extended OPND1*)
MAINCODE.LAST↑.NEXTPTR := TPTR;
MAINCODE.LAST := TPTR;
TPTR↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(TPTR)
end;
NEWINSTREC := TPTR
end (*EMIT_INSTR_OPNDS*);
procedure INSERT_INSTR_OPNDS(var WHERE : A_CODEREC; W1 : S1WORD;
var OPND1, OPND2 : OPERAND);
(*Common to EMIT routines. Fill in the short operand fields in W1,
insert a CODEREC containing W1 immediately following WHERE (at
front if WHERE = nil), and allocate and insert extended words if
needed. Return a pointer to the last CODEREC inserted in WHERE.
Update MAINCODE to reflect insertions. Does Not touch
NEWINSTREC.*)
var IPTR, NXPTR, TPTR, TTPTR : A_CODEREC;
begin
NEWCODEREC(IPTR);
if WHERE = nil then
begin
NXPTR := MAINCODE.FIRST;
MAINCODE.FIRST := IPTR
end
else (*WHERE <> nil*)
begin
if not (MAINCODE.FIRST<>nil) then ASSERTFAIL('INSERT_IN001');
NXPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := IPTR
end;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := IPTR;
if OPND2.X = 1 then
begin (*extended OPND2*)
NEWCODEREC(TTPTR);
TPTR↑.NEXTPTR := TTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := TTPTR
end
else TTPTR := nil;
BUILD_CW_OPERAND(W1,TTPTR,OPND2,OPND2_START);
if OPND1.X = 1 then
begin (*extended OPND1*)
NEWCODEREC(TTPTR);
TPTR↑.NEXTPTR := TTPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
TPTR := TTPTR
end
else TTPTR := nil;
BUILD_CW_OPERAND(W1,TTPTR,OPND1,OPND1_START);
IPTR↑.CODEWORD := W1;
TPTR↑.NEXTPTR := NXPTR;
if MAINCODE.LAST = WHERE then MAINCODE.LAST := TPTR;
WHERE := TPTR
end (*INSERT_INSTR_OPNDS*);
(** CODE_EMITTER_CLASS: EMITFAKEINST INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
(**)
procedure EMITFAKEINST(* (FAKEOPC : S1OPCODE; FAKEOPND : integer) *); (*PBK*)
(*Emit the fake S1 instruction described.*)
begin
if not (OPFORMAT[FAKEOPC] = VFAKEOP) then ASSERTFAIL('EMITFAKEI001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[FAKEOPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN,
FAKEOPND);
if MAINCODE.NWORDS = 0 then MAINCODE.FIRST := NEWINSTREC
else MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.LAST := NEWINSTREC;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
NEWCODEREC(NEWINSTREC)
end (*EMITFAKEINST*);
procedure INSERTSOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND;
SKIPDEST : A_CODEREC);
(*Insert the described SOP instruction after the coderec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var WORD : S1WORD;
TPTR : A_CODEREC;
begin
if not ( OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('INSERTSOP001');
WORD := ZEROS1WORD;
PUTFIELD (WORD, OPCODE_START, OPCODE_LEN, HARDOPCODE[S1OPC]);
PUTFIELD (WORD, SKP_START, SKP_LEN, SKIPDIST);
INSERT_INSTR_OPNDS (WHERE, WORD, OPND1, OPND2);
NEWCODEREC (TPTR);
TPTR↑.NEXTPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := TPTR;
TPTR↑.CODEPTR := SKIPDEST;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
if TPTR↑.NEXTPTR = nil then
MAINCODE.LAST := TPTR;
end (*INSERTSOP*);
procedure INSERTJOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
FORCELONG : BIT; var OPND1, OPND2 : OPERAND;
JUMPDEST : A_CODEREC);
(*Insert the described JOP instruction after the CODEREC that WHERE
points to, updating MAINCODE to reflect changes. Does Not use
NEWINSTREC. WHERE = nil means insert at front.*)
var WORD : S1WORD;
TPTR : A_CODEREC;
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('INSERTJOP001');
WORD := ZEROS1WORD;
PUTFIELD(WORD,OPCODE_START,OPCODE_LEN,HARDOPCODE[S1OPC]);
PUTFIELD(WORD,PR_START,PR_LEN,FORCELONG);
INSERT_INSTR_OPNDS(WHERE,WORD,OPND1,OPND2);
NEWCODEREC(TPTR);
TPTR↑.NEXTPTR := WHERE↑.NEXTPTR;
WHERE↑.NEXTPTR := TPTR;
TPTR↑.CODEPTR := JUMPDEST;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
if TPTR↑.NEXTPTR = nil then
MAINCODE.LAST := TPTR
end (*INSERTJOP*);
procedure INSERTXOP(WHERE : A_CODEREC; S1OPC : S1OPCODE;
var OPND1, OPND2 : OPERAND);
(*Insert the described XOP instruction after the coderec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var WORD : S1WORD;
begin
if not ( OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('INSERTXOP001');
WORD := ZEROS1WORD;
PUTFIELD (WORD, OPCODE_START, OPCODE_LEN, HARDOPCODE[S1OPC]);
INSERT_INSTR_OPNDS (WHERE, WORD, OPND1, OPND2);
end (*INSERTSOP*);
procedure EMIT_S1WORD(var LIST : CODELIST; var W : S1WORD);
(*Add the word to the end of the codelist.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := W
end (*EMIT_S1WORD*);
procedure EMIT_ZEROS1WORD(var LIST : CODELIST;
var WHERE : A_CODEREC);
(*Add a zero S1WORD to the end of LIST, returning a pointer to it.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := ZEROS1WORD;
WHERE := LIST.LAST
end (*EMIT_ZEROS1WORD*);
(** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
(**)
procedure EMITSOP(S1OPC : S1OPCODE; SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND; SKIPDEST : A_CODEREC);
(*Add described SOP instr, including extra word at the end for the
SKIPDEST, to the end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('EMITSOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,SKP_START,SKP_LEN,SKIPDIST);
EMIT_INSTR_OPNDS(OPND1,OPND2);
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
MAINCODE.LAST := NEWINSTREC;
NEWCODEREC(NEWINSTREC);
MAINCODE.LAST↑.CODEPTR := SKIPDEST
end (*EMITSOP*);
procedure EMITJOP(S1OPC : S1OPCODE; FORCELONG : BIT;
var OPND1, OPND2 : OPERAND; JUMPDEST : A_CODEREC);
(*Add described JOP instr, including extra word at the end for the
JUMPDEST, to the end of MAINCODE. FORCELONG = 1 means that the
jump must be concretized into a two word instruction (or a one
word instr and a one word no-op). This bit of information is
stored for the time being in the PR field.*)
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('EMITJOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,PR_START,PR_LEN,FORCELONG);
EMIT_INSTR_OPNDS(OPND1,OPND2);
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
MAINCODE.LAST := NEWINSTREC;
NEWCODEREC(NEWINSTREC);
MAINCODE.LAST↑.CODEPTR := JUMPDEST
end (*EMITJOP*);
procedure EMITTOP(S1OPC : S1OPCODE; T : TWOBITS;
var OPND1, OPND2 : OPERAND);
(*Add described TOP instr to end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VTOP) then ASSERTFAIL('EMITTOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
PUTFIELD(NEWINSTREC↑.CODEWORD,T_START,T_LEN,T);
EMIT_INSTR_OPNDS(OPND1,OPND2);
end (*EMITTOP*);
procedure EMITXOP(*(S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND)*);
(*Add described XOP instr to end of MAINCODE.*)
begin
if not (OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('EMITXOP 001');
PUTFIELD(NEWINSTREC↑.CODEWORD,OPCODE_START,OPCODE_LEN,
HARDOPCODE[S1OPC]);
EMIT_INSTR_OPNDS(OPND1,OPND2);
end (*EMITXOP*);
procedure ALLOC_AND_EMIT_TOP(var R : S1REGISTER; OPCD : S1OPCODE;
var OPND1, OPND2 : OPERAND;
DOUBRES, DOUB1, DOUB2 : boolean;
STE : STKINX);
(*Allocate a register (returned in R) for the result of a TOP,
perhaps emitting a MOV to free it, and emit the TOP. Assume that
OPND1 and OPND2 regs were Not freed in advance, but will be freed
after return, being careful to not free reg R even if it
coincides with OPND1 or OPND2.
Note: DOUBRES, DOUB1, DOUB2 are true iff the result, opnd1,
and opnd2 respectively are doublewords. This can be deduced
from the opcode if the proper tables are declared.*)
var OPNDR : OPERAND;
MOVEOP : S1OPCODE;
begin
if not ( REVERSE_OP[OPCD]<>XILLEGAL) then ASSERTFAIL('ALLOC_AND001');
if IS_T_REG_NOT_RT(OPND1) and (DOUBRES <= DOUB1) then
begin
if IS_T_REG_NOT_RT(OPND2) and
(DOUBRES <= DOUB2) and (OPND2.F < OPND1.F) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else
begin
R := OPND1.F;
EMITTOP (OPCD, 0, OPND1, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end
else if IS_T_REG_NOT_RT(OPND2) and (DOUBRES <= DOUB2) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else if IS_RTA(OPND1) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (OPCD, 1, OPNDR, OPND2);
end
else if IS_RTA(OPND2) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (REVERSE_OP[OPCD], 1, OPNDR, OPND1);
end
else if RISFREE[S1RTA] or USES_RTA(OPND1) or USES_RTA(OPND2) then
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if DOUBRES then ALLOCRP(S1RTA) else ALLOCRG(S1RTA);
R := S1RTA;
EMITTOP (OPCD, 2, OPND1, OPND2);
end
else if RISFREE[S1RTB] or USES_RTB(OPND1) or USES_RTB(OPND2) then
begin
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
if DOUBRES then ALLOCRP(S1RTB) else ALLOCRG(S1RTB);
RTBUSER := STE;
RTBDOUB := DOUBRES;
R := S1RTB;
EMITTOP (OPCD, 3, OPND1, OPND2);
end
else
begin (*if all else fails, emit a move*)
if DOUB1 or DOUBRES then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
if DOUB1 then MOVEOP:=XMOV_D_D else MOVEOP:=XMOV_S_S;
EMITXOP (MOVEOP, OPNDR, OPND1);
R := NXTRG;
EMITTOP (OPCD, 0, OPNDR, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end (*ALLOC_AND_EMIT_TOP*);
(** DATUM_PROCESSOR_CLASS: LENGTH_TO_INTOPNDTYPE REG_DATUM COERCE_DATUM CVT_INT_DATUM COERCE_INT_DATUM COERCE_TWO_DATUMS DATUM_IS_REG DATUM_ISFREE_REG DATUM_IS_T_REG DATUM_IS_FILADR LOADSTKENTRY LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM XCHANGE_STKENTS **)
(**)
procedure GET_OPERAND (var OPND : OPERAND; STE : STKINX);
forward;
procedure FIT_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
forward;
procedure MOVE_QUANTITY (var DEST : OPERAND; STE : STKINX);
forward;
procedure SIMPLIFY (STE : STKINX);
forward;
procedure ADD_SUB_SINGLE (var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX);
forward;
function LENGTH_TO_INTOPNDTYPE(LEN : DTYPE_LENGTH) : OPNDTYPE;
(*Return the integer type whose precision corresponds to
the length LEN in bits -- als/peg 19jul79.*)
begin
if LEN mod QWBITS <> 0 then ASSERTFAIL('LENGTH_TO001');
if LEN = DWBITS then
LENGTH_TO_INTOPNDTYPE := TYPUI
else if LEN = WORDBITS then
LENGTH_TO_INTOPNDTYPE := TYPUJ
else if LEN = HWBITS then
LENGTH_TO_INTOPNDTYPE := TYPH
else if LEN = QWBITS then
LENGTH_TO_INTOPNDTYPE := TYPQ
else ASSERTFAIL('LENGTH_TO002');
end (*LENGTH_TO_INTOPNDTYPE*);
procedure REG_DATUM (STE : STKINX; RESCODESTART : A_CODEREC;
RESTYPE : OPNDTYPE; RESREG : S1REGISTER);
(*Build a datum in STK[STE] describing a quantity stored in a
given register, with a given CODESTART and DTYPE.*)
(* als/peg 03jul79 *)
var R : S1REGISTER;
begin
STK[STE] := ZERODATUM;
with STK[STE] do
begin
CODESTART := RESCODESTART;
DTYPE := RESTYPE;
if RPWORD[RESREG] = R1STOFPAIR then
DLENGTH := 2*WORDBITS
else if RPWORD[RESREG] = R1STOFBLOCK then
begin
R := RESREG + 1;
DLENGTH := WORDBITS;
while RPWORD[R] = RINBLOCK do
begin
DLENGTH := DLENGTH + WORDBITS;
R := R + 1;
end;
end
else DLENGTH := WORDBITS;
MTYPE := R_SPACE;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := RESREG;
end;
end (*REG_DATUM*);
procedure COERCE_DATUM(STE : STKINX; RTYPE : OPNDTYPE);
(*Perform a type coercion of the datum STE to type RTYPE*)
var OPND, OPNDR : OPERAND;
OPRRG : S1REGISTER;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if DTYPE <> RTYPE then
begin
MOVEOP := MOV_X_Y[RTYPE,DTYPE];
if MOVEOP = XILLEGAL then
ERROR(WINVALID_TYPE_COERCION);
if IS_CONSTANT(STE) then
if (DTYPE = TYPUN) and (RTYPE = TYPUA) then
(*leave TYPUN alone, it's already TYPUA (sort of)*)
else if IS_INTEGER[RTYPE] and IS_INTEGER[DTYPE] then
if (RTYPE in [TYPUI, TYPUK])
or (DTYPE in [TYPUI, TYPUK]) then
ERROR(WNOT_IMPLEMENTED)
else
DTYPE := RTYPE
else if IS_INTEGER[RTYPE] and IS_REAL[DTYPE] then
if RTYPE = TYPUQ then ERROR(WNOT_IMPLEMENTED)
else
begin
FPA.WHICH := MEM;
FPA.MEMADR.DSPLMT := round(RCNST);
DTYPE := RTYPE
end
else if IS_REAL[RTYPE] and IS_INTEGER[DTYPE] then
if (RTYPE = TYPUQ) or (DTYPE in [TYPUI, TYPUK]) then
ERROR(WNOT_IMPLEMENTED)
else
begin
RCNST := FPA.MEMADR.DSPLMT;
FPA := ZEROFPA;
DTYPE := RTYPE;
end
else ERROR(WINVALID_TYPE_COERCION)
else if DTYPE = TYPUM then
begin
if not (RTYPE = TYPUA) then ASSERTFAIL('COERCE_DA001');
repeat SIMPLIFY(STE) until DTYPE = TYPUA;
end
else
begin
GET_OPERAND(OPND,STE);
if IS_DOUBLE[RTYPE] then FINDRP else FINDRG;
OPRRG := NXTRG;
REG_OPERAND(OPNDR, OPRRG);
EMITXOP(MOVEOP, OPNDR, OPND);
FREEDATUMREGS(STE);
REG_DATUM(STE, CODESTART, RTYPE, OPRRG);
end;
end;
end (*COERCE_DATUM*);
procedure CVT_INT_DATUM(STE : STKINX);
(*The datum in the stack at STE is TYPUJ or TYPUL. If it is of qword
or hword length, convert it to TYPQ or TYPH -- als/peg 20jul79.*)
begin
with STK[STE] do
begin
if not (DTYPE in [TYPUJ, TYPUL]) then ASSERTFAIL('CVT_INT_D001');
if DLENGTH <> WORDBITS then
DTYPE := LENGTH_TO_INTOPNDTYPE(DLENGTH);
end (*with*);
end (*CVT_INT_DATUM*);
procedure COERCE_INT_DATUM(STE : STKINX);
(*The datum in the stack at STE is TYPUJ or TYPUL, but may be
of qword or hword length. Coerce it to sword length --
als/peg 20jul79.*)
var RESTYPE : OPNDTYPE;
begin
with STK[STE] do
begin
if not (DTYPE in [TYPUJ, TYPUL]) then ASSERTFAIL('COERCE_IN001');
RESTYPE := DTYPE;
if DLENGTH <> WORDBITS then
begin
DTYPE := LENGTH_TO_INTOPNDTYPE(DLENGTH);
COERCE_DATUM(STE, RESTYPE);
end;
end (*with*);
end (*COERCE_INT_DATUM*);
procedure COERCE_TWO_DATUMS(var IS_OKTYPE :
OPNDTYPE_TO_BOOLEAN_ARRAY);
(*Instead of IS_OKTYPE, could possibly pass a set
of legal result types.*)
(*Take the top two datums on the stack, verify that they represent
acceptable types, and emit code to coerce them both to the same
result type.*)
var TYPE1, TYPE2, RTYPE : OPNDTYPE;
begin
TYPE1 := STK[TOP-1].DTYPE;
TYPE2 := STK[TOP].DTYPE;
if not IS_OKTYPE[TYPE1] or not IS_OKTYPE[TYPE2] then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
RTYPE := ARITH_RESULT_TYPE[TYPE1,TYPE2];
if RTYPE = ILLARITH then
ERROR (WBINARY_OPND_TYPE_CONFLICT);
COERCE_DATUM(TOP-1,RTYPE);
COERCE_DATUM(TOP,RTYPE)
end (*COERCE_TWO_DATUMS*);
function DATUM_IS_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
register.*)
begin
with STK[STE] do
DATUM_IS_REG := (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS);
end (*DATUM_IS_REG*);
function DATUM_ISFREE_REG (STE : STKINX) : boolean; (*EJG 17JAN79*)
(*PEG 18FEB79*)
(*Return true iff datum specifies a quantity contained in a
register which is currently free.*)
begin
DATUM_ISFREE_REG := false;
with STK[STE] do
if (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS)
then if RISFREE[VPA1.VPA.RGADR] then DATUM_ISFREE_REG := true;
end (*DATUM_ISFREE_REG*);
function DATUM_IS_T_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
temporary register.*)
begin
with STK[STE] do
DATUM_IS_T_REG := (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS) and
(*finally:*)
((VPA1.VPA.RGADR = S1RTA) or
(VPA1.VPA.RGADR = S1RTB) or
(MINTMPS1REG <= VPA1.VPA.RGADR) and
(VPA1.VPA.RGADR <= MAXTMPS1REG));
end (*DATUM_IS_T_REG*);
function DATUM_IS_FILADR (STE : STKINX) : boolean;
(*Return true iff datum specifies the quantity at U-Code
location <1,LCIOFILADR>. *)
begin
with STK[STE] do
DATUM_IS_FILADR :=
(DTYPE = TYPUA) and
(FINALIND = IND0) and
(FPA = ZEROFPA) and
(NVPAS = 1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPAIND = IND1) and
(VPA1.VPA.WHICH = MEM) and
(VPA1.VPA.MEMADR.LVL = 1) and
(VPA1.VPA.MEMADR.DSPLMT
= LCIOFILADR + FILE_OFFSET);
end (*DATUM_IS_FILADR*);
procedure XCHANGE_STKENTS (STE1, STE2 : STKINX); (*peg 15MAY79*)
(*Exchange the datum at STK[STE1] with that at STK[STE2].*)
var T_DATUM : DATUM;
begin
T_DATUM := STK[STE1];
STK[STE1] := STK[STE2];
STK[STE2] := T_DATUM;
end (*XCHANGE_STKENTS*);
procedure BJUMP_TO_BINTVAL (STE : STKINX);
(*Convert the datum, which is a boolean in bjump form, into
bintval form.*)
(*This procedure probably could be done more easily simply by
loading a zero, then executing a conditional-skip tree which
may load a one at the end or may skip the load. LCW*)
var LOADFIRST : boolean;
FALLTHRUJUMP : A_CODEREC;
OPNDR, OPND2 : OPERAND;
TLOAD, FLOAD, SKIPLOC, CONTINUE : A_CODEREC;
P, NEXT : A_CODEREC;
begin
with STK[STE] do
begin
if not ((DTYPE=TYPUB) and (BREPRES=BJUMP)) then
ASSERTFAIL('BJUMP_TO_001');
FALLTHRUJUMP := NEXT_INSTRUCTION(BFALLTHRUSKIPLOC);
if BTRUELIST.NWORDS < BFALSELIST.NWORDS then
LOADFIRST := (true)
else LOADFIRST := (false);
P := AFTER_LAST_XWORD(BFALLTHRUSKIPLOC);
P↑.NEXTPTR := NEXT_INSTRUCTION(P↑.NEXTPTR);
(*remove the fall-through jump*)
if LOADFIRST <> BJUMPON then
begin
INVERT_SKIP (BFALLTHRUSKIPLOC);
BJUMPON := not BJUMPON;
end;
REG_OPERAND (OPNDR, VPA1.VPA.RGADR);
(*Use the reg allocated to the bjump when created.*)
if LOADFIRST = (true) then
begin (*load true first*)
IMM_OPERAND (OPND2, 1);
INSERTXOP (P, XMOV_Q_Q, OPNDR, OPND2);
TLOAD := P↑.NEXTPTR;
P := TLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
P := AFTER_LAST_XWORD(SKIPLOC);
INSERTXOP (P, XMOV_Q_Q, OPNDR, ZERO_OP);
FLOAD := P↑.NEXTPTR;
FIXSOP (BFALLTHRUSKIPLOC, FLOAD);
CONTINUE := NEXT_INSTRUCTION(FLOAD);
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load true first*)
else
begin (*load false first*)
INSERTXOP (P, XMOV_Q_Q, OPNDR, ZERO_OP);
FLOAD := P↑.NEXTPTR;
P := FLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
P := AFTER_LAST_XWORD(SKIPLOC);
IMM_OPERAND (OPND2, 1);
INSERTXOP (P, XMOV_Q_Q, OPNDR, OPND2);
TLOAD := P↑.NEXTPTR;
FIXSOP (BFALLTHRUSKIPLOC, TLOAD);
CONTINUE := NEXT_INSTRUCTION(TLOAD);
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load false first*);
P := BTRUELIST.FIRST;
while P <> nil do
begin
NEXT := JUMPSKIPDEST(P);
FIXJOP (P, TLOAD);
P := NEXT;
end;
P := BFALSELIST.FIRST;
while P <> nil do
begin
NEXT := JUMPSKIPDEST(P);
FIXJOP (P, FLOAD);
P := NEXT;
end;
REG_DATUM (STE, CODESTART, TYPUB, VPA1.VPA.RGADR);
BREPRES := BINTVAL;
end (*with STK[STE] do*)
end (*BJUMP_TO_BINTVAL*);
procedure LOADSTKENTRY(STE : STKINX);
(*Force an actual load of the item at STK[STE] -- als/peg 27jul79.*)
var OPND, OPNDR : OPERAND;
R : S1REGISTER;
begin
with STK[STE] do
if (NVPAS>0) and
not DATUM_IS_FILADR(STE) and
not DATUM_IS_T_REG(STE) and
not DATUM_ISFREE_REG(STE) then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL(STE)
else
begin
GET_OPERAND(OPND, STE);
if not DATUM_IS_T_REG(STE) then
begin (*generate a MOV*)
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
R := NXTRG;
REG_OPERAND (OPNDR, R);
MOVE_QUANTITY (OPNDR, STE);
FREEDATUMREGS (STE);
REG_DATUM (STE, CODESTART, DTYPE, R);
end (*generate a MOV*);
end;
end (*LOADSTKENTRY*);
procedure LOADSTACKEXCEPT (BOTEXC, TOPEXC : STKINX);
(*In order to prevent possible side effects because of standard
procedure calls or user procedure calls inside codeforks, we
call this procedure to load most items on the virtual stack into
temporary registers. Exceptions are constants (which are
completely in virtual form) and bjump booleans (which have no
storage associated with them that can be changed). There are
often stack entries, however, which we don't need or wish to
load in this way, because they are parameters which are being
passed or because we are about to throw them away anyway. The
range BOTEXC<=STE<=TOPEXC consists of such entries, and items in
that part of the stack are not loaded. Any DATUM which is a
file address is also not loaded. (A kludge so CHECKFILADR
will be able to tell which DATUMs are file addresses.) Later,
file addresses will be passed as parameters.*)
var OPNDR : OPERAND;
STE : STKINX;
R : S1REGISTER;
begin
for STE := BOT to TOP do
with STK[STE] do
if ((STE<BOTEXC) or (STE>TOPEXC)) and (NVPAS>0) and
((DTYPE<>TYPUB) or (BREPRES=BINTVAL)) and
not DATUM_IS_FILADR(STE) and
not DATUM_IS_T_REG(STE) and
not DATUM_ISFREE_REG(STE) then (*EJG 17JAN79*)
begin (*generate a MOV*)
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
R := NXTRG;
REG_OPERAND (OPNDR, R);
MOVE_QUANTITY (OPNDR, STE);
FREEDATUMREGS (STE);
REG_DATUM (STE, CODESTART, DTYPE, R);
end (*generate a MOV*);
end (*LOADSTACKEXCEPT*);
procedure INCREMENT_DATUM(STE : STKINX; INCR : integer); (*EJG*)
(*Increment the datum STE by the constant amount INCR*)
var
OLDTYPE : OPNDTYPE;
OPND1, OPND2 : OPERAND;
COMBINABLE, CALCULABLE, RESDBL : boolean;
TOOMUCH1 : boolean;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((IS_INTEGER[DTYPE])
or (DTYPE in [TYPUA, TYPUB, TYPUC, TYPUM])) then
ERROR (WNOT_DISCRETE_TYPE);
if INCR <> 0 then
begin
OLDTYPE := DTYPE;
if DTYPE in [TYPUB, TYPUC] then
begin
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL (STE);
DTYPE := TYPQ;
end;
if IS_INTEGER[DTYPE] then
if IS_CONSTANT(STE) then
begin
if IS_DOUBLE[DTYPE] then ERROR(WNOT_IMPLEMENTED)
else FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + INCR;
DTYPE := OLDTYPE;
end (*constant*)
else (*not constant*)
begin
if DTYPE in [TYPUJ, TYPUL] then
COERCE_INT_DATUM(STE);
RESDBL := IS_DOUBLE[DTYPE];
if RESDBL then S1OP := XADD_D
else S1OP := XADD_S;
GET_OPERAND (OPND1, STE);
IMM_OPERAND (OPND2, INCR);
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, STE);
FREEREGSBUTTHESE (STE, [DEST]);
REG_DATUM (STE, CODESTART, OLDTYPE, DEST);
end (*if IS_INTEGER*)
else
begin (*TYPUA, TYPUM*)
COMBINABLE := false;
CALCULABLE := false;
repeat
if FINALIND = IND0 then COMBINABLE := true
else
begin
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if TOOMUCH1 then
SIMPLIFY (STE)
else
CALCULABLE := true;
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + INCR
else
begin (*calculable*)
IMM_OPERAND (OPND2, INCR);
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, STE);
FREEREGSBUTTHESE (STE, [DEST]);
REG_DATUM (STE, CODESTART, DTYPE, DEST);
end (*calculable*);
end (*TYPUA, TYPUJ, TYPUM*);
end (*if INCR <> 0*);
end (*with STK[STE]*);
end (*INCREMENT_DATUM*);
(** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE INC_INDIRECTION TRANSLATE_LVLDSP **)
(**)
procedure BINTVAL_TO_BJUMP (STE : STKINX);
(*Convert the datum, which is a boolean in bintval form,
into bjump form.*)
var OPND : OPERAND;
SKIPLOC : A_CODEREC;
RESCODESTART : A_CODEREC;
begin
with STK[STE] do
begin
if not ((DTYPE=TYPUB) and (BREPRES=BINTVAL)) then
ASSERTFAIL('BINTVAL_T001');
GET_OPERAND (OPND, STE);
LOADSTACKEXCEPT (STE, STE);
if not RISFREE[S1RTB] and (RTBUSER <> STE) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (STE);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_EQL_Q, 0, OPND, ZERO_OP, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
RESCODESTART := CODESTART;
STK[STE] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[STE] do*);
end (*BINTVAL_TO_BJUMP*);
procedure PARMREG_TO_PARMSAVE (STE : STKINX; PWORD : NONNEGINT);
(*If the datum contains references to parameter registers
logically preceding (but not including) parameter register
number 'PWORD', convert those references to the corresponding
location in the local parameter save area.*)
var P : integer;
begin
with CURPROCSPEC, STK[STE] do
if NVPAS >= 1 then if VPA1.VPA.WHICH = RGS then if
IS_PARMREG(VPA1.VPA.RGADR) then if
S1REG_TO_PRM[VPA1.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA1.VPA.RGADR];
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := CURLVL;
VPA1.VPA.MEMADR.DSPLMT := R_OFFSET + P*WORDUNITS;
if NVPAS>=2 then if VPA2.VPA.WHICH=RGS then if
IS_PARMREG(VPA2.VPA.RGADR) then if
S1REG_TO_PRM[VPA2.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA2.VPA.RGADR];
VPA2.VPA.WHICH := MEM;
VPA2.VPA.MEMADR.LVL := CURLVL;
VPA2.VPA.MEMADR.DSPLMT := R_OFFSET + P*WORDUNITS;
end;
end;
end (*PARMREG_TO_PARMSAVE*);
procedure INC_INDIRECTION(STE : STKINX; MAXFINALIND : INDIRECTION);
(*Increase the indirection on the datum at STK[STE] once
-- als/peg 19jul79.*)
begin
with STK[STE] do
begin
while FINALIND > MAXFINALIND do
SIMPLIFY (TOP);
if FPA.WHICH = RGS then ASSERTFAIL('INC_INDIR001');
if NVPAS = 0 then
begin (*move FPA to VPA*)
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA := FPA;
FPA := ZEROFPA;
end (*move FPA to VPA*)
else if (NVPAS=1) and (FPA=ZEROFPA) then
begin (*increase indirection on single VPA*)
if VPA1.VSHIFT<>0 then
ERROR (WINDEX_WITHOUT_BASE);
if VPA1.VPAIND = IND1 then VPA1.VPAIND := IND2
else FINALIND := succ(FINALIND);
end (*increase indirection on single VPA*)
else
(*the datum has multiple parts*)
FINALIND := succ(FINALIND);
end (*with STK[STE] do*);
end (*INC_INDIRECTION*);
procedure TRANSLATE_LVLDSP(var X : MEMOREG; MEMAREA : MEMTYPE);
(*Translates a U-Code (LVL,DSPLMT) into an S1 (LVL,DSPLMT) or an
S1REGISTER.*)
var TMPLVL : 0..MAXLVL;
begin
if not (X.WHICH = MEM) then ASSERTFAIL('TRANSL_LV001');
if not (X.MEMADR.LVL <= CURLVL) then ASSERTFAIL('TRANSL_LV002');
if not (X.MEMADR.DSPLMT mod QWBITS = 0) then ASSERTFAIL('TRANSL_LV003');
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT div QWBITS;
TMPLVL := X.MEMADR.LVL;
if TMPLVL = 1 then
if MEMAREA = M_SPACE then
if X.MEMADR.DSPLMT < LASTFILBUF then
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT + FILE_OFFSET
else X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - L1FIRSTADDR + M_OFFSET
else ERROR(WNOT_IMPLEMENTED)
else if (TMPLVL = CURLVL) and (MEMAREA = R_SPACE)
and not PREGS_ARCHIVED then
begin (*map local parm into its register*)
X.RGADR := PRM_TO_S1REG[(X.MEMADR.DSPLMT) div WORDUNITS];
X.WHICH := RGS
end
else if MEMAREA in [R_SPACE, M_SPACE] then
case MEMAREA of
R_SPACE : X.MEMADR.DSPLMT := X.MEMADR.DSPLMT + R_OFFSET;
M_SPACE : X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - FIRSTADDR + M_OFFSET
end (*case*)
else
ERROR(WNOT_IMPLEMENTED);
end (*TRANSLATE_LVLDSP*);
(** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CONST_PLUS_OPND PUSHTOP POPTOP PUSH_STKFRAME POP_STKFRAME **)
(**)
function IS_SIMPLE (var V : VPAREC) : boolean;
(*Return true iff the VPA specifies an unshifted quantity
stored in a register.*)
begin
IS_SIMPLE := (V.VPAIND=IND1) and (V.VSHIFT=0)
and (V.VPA.WHICH=RGS);
end (*IS_SIMPLE*);
function FITS_SHRT_OFFSET (*(DISP : S1DISP) : boolean*);
(*Returns true iff the displacement is such that it
can be used in a short index.*)
begin
FITS_SHRT_OFFSET := (DISP mod WORDUNITS = 0)
and (MINSHORTOFFSET <= DISP div WORDUNITS)
and (DISP div WORDUNITS <= MAXSHORTOFFSET)
END (*FITS_SHRT_OFFSET*);
function FITS_SHORT_INDEX (var V : VPAREC) : boolean;
(*Returns true iff the VPA can be inserted as the
short index of an extended operand.*)
var D : INTEGER;
begin
if V.VPA.WHICH = RGS then FITS_SHORT_INDEX := true
else
begin
D := V.VPA.MEMADR.DSPLMT div WORDUNITS;
FITS_SHORT_INDEX := (V.VPAIND = IND1)
and (V.VPA.MEMADR.LVL > 0)
and (V.VPA.MEMADR.DSPLMT mod WORDUNITS = 0)
and (MINSHORTOFFSET <= D)
and (D <= MAXSHORTOFFSET)
end
end (*FITS_SHORT_INDEX*);
function IS_CONSTANT (*(STE : STKINX) : boolean*);
(*Return true iff datum represents a constant.*)
begin
with STK[STE] do
IS_CONSTANT := (FINALIND = IND0)
and (NVPAS = 0)
and (FPA.WHICH = MEM)
and (DTYPE <> TYPUM)
and ( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) )
and (FPA.MEMADR.LVL = 0);
end (*IS_CONSTANT*);
function IS_CONST_PLUS_OPND (STE : STKINX) : boolean;
(*Return true iff datum represents a nonzero constant plus
other parts which will fit in an operand if the constant
part is excluded.*)
begin
with STK[STE] do
IS_CONST_PLUS_OPND := (FINALIND = IND0)
and not (DTYPE in [TYPUB, TYPUM])
and (FPA.WHICH = MEM)
and (FPA.MEMADR.DSPLMT <> 0)
and ( (FPA.MEMADR.LVL=0) and (NVPAS=1)
and (VPA1.VSHIFT=0)
or (FPA.MEMADR.LVL<>0)
and (NVPAS=0) );
end (*IS_CONST_PLUS_OPND*);
procedure PUSHTOP;
(*Push an undefined datum onto the virtual stack,
checking for overflow.*)
begin
if TOP < MAXSTKINX then TOP := TOP + 1
else ERROR (WEXPR_TOO_COMPLEX);
end (*PUSHTOP*);
procedure POPTOP;
(*Pop the top value from the stack and discard it,
checking for underflow.*)
begin
if TOP >= BOT then TOP := TOP - 1
else ERROR (WPOP_OF_EMPTY_STACK);
end (*POPTOP*);
procedure PUSH_STKFRAME;
(*Push a new stack frame onto the virtual stack -- peg 13jul79.*)
begin
if CURFRAME >= MAXFRAME then ASSERTFAIL('PUSH_STKF001');
STKFRAME[CURFRAME] := BOT;
CURFRAME := CURFRAME + 1;
PUSHTOP; STK[TOP] := ZERODATUM;
BOT := TOP;
POPTOP;
end (*PUSH_STKFRAME*);
procedure POP_STKFRAME;
(*Pop a stack frame from the virtual stack -- peg 13jul79.*)
begin
if CURFRAME <= MINFRAME then ASSERTFAIL('POP_STKFR001');
CURFRAME := CURFRAME - 1;
BOT := STKFRAME[CURFRAME];
end (*POP_STKFRAME*);
(** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
(**)
procedure UPD_REALTBL (var DISP : S1DISP; RVAL : real);
(*Add the real to the real table if not already there. Return
its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W : S1WORD;
begin
FOUND := false;
DISP := 0;
PTR := REALTBL.FIRST;
REAL_TO_S1WORD (W, RVAL);
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (REALTBL, W);
end;
end (*UPD_REALTBL*);
procedure UPD_SETTBL (var DISP : S1DISP; SVAL : SETREP);
(*Add the entire set to the set table if not already there.*)
var FOUND : boolean;
PTR : A_CODEREC; (*setch...*)
CNT : 0..S1SETREP_SIZE;
INDEX : S1SETREP_INDEX;
S1SET : S1SETREP; (*...setch*)
begin
FOUND := false;
DISP := 0;
PTR := SETTBL.FIRST;
SETREP_TO_S1WORDS (S1SET, SVAL); (*setch*)
while not FOUND and (PTR <> nil) do
begin (*setch...*)
CNT := 0;
for INDEX := 0 to S1SETREP_MAX do
begin
if PTR↑.CODEWORD = S1SET[INDEX] then CNT := CNT + 1;
PTR := PTR↑.NEXTPTR;
end;
if CNT = S1SETREP_SIZE then FOUND := true
else DISP := DISP + S1SETREP_SIZE*WORDUNITS;
end (*while*);
if not FOUND then
for INDEX := 0 to S1SETREP_MAX do
EMIT_S1WORD(SETTBL, S1SET[INDEX]); (*...setch*)
end (*UPD_SETTBL*);
procedure UPD_PROCTBL (var FIXPTR : A_PROCENT; var PID : ALFA);
(*Add the name in PID to the proc table if not already there and
return a pointer to the entry for fixup purposes.*)
var PTR : A_PROCENT;
begin
if PROCTBL.FIRST = nil then
begin
new (PROCTBL.FIRST);
with PROCTBL.FIRST↑ do
begin
NAME := PID; FIXLIST := EMPTYCODELIST; NEXTPTR := nil;
end;
PROCTBL.NPROCS := 1;
FIXPTR := PROCTBL.FIRST;
end
else
begin (*non-empty table*)
PTR := PROCTBL.FIRST;
while (PTR↑.NEXTPTR <> nil) and (PTR↑.NAME <> PID) do
PTR := PTR↑.NEXTPTR;
if PTR↑.NAME = PID then FIXPTR := PTR
else
begin (*add at end*)
new (PTR↑.NEXTPTR);
with PTR↑.NEXTPTR↑ do
begin
NAME := PID;
FIXLIST := EMPTYCODELIST;
NEXTPTR := nil;
end;
PROCTBL.NPROCS := PROCTBL.NPROCS + 1;
FIXPTR := PTR↑.NEXTPTR;
end (*add at end*);
end (*non-empty table*);
end (*UPD_PROCTBL*);
(** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
(**)
procedure UPD_LBLTBL (*(var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LCODEPTR)*);
(*Add an entry for this label to the label hash table if one is not
already there. Return in LPTR a pointer to the entry.*)
var H : RNG_0_LBLHTSIZEM1;
PTR : A_LBLHASHENT;
FOUND : boolean;
begin
H := LABELHASH (LNUM);
PTR := LBLHASHTAB[H];
FOUND := false;
while not FOUND and (PTR <> nil) do
if PTR↑.LBLNUM = LNUM then FOUND := true
else PTR := PTR↑.NEXTPTR;
if FOUND then LPTR := PTR
else
begin (*add to front*)
new (PTR);
PTR↑.NEXTPTR := LBLHASHTAB[H];
LBLHASHTAB[H] := PTR;
PTR↑.LBLNUM := LNUM;
PTR↑.DEFINED := false;
case LCLASS of
LINTVAL : PTR↑.CLIST := EMPTYCODELIST;
LCODEPTR :
begin
PTR↑.JLIST := EMPTYJUMPLIST;
PTR↑.JUMPTABLELABEL := false
end
end (*case*);
LPTR := PTR;
end (*add to front*);
end (*UPD_LBLTBL*);
procedure UPD_BOUNDTBL (var DISP : S1DISP; LOW, HI : integer;
BNDTYP : OPNDTYPE);
(*Add the bound triple to the bound table if not already there.
Return its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W1, W2, W3 : S1WORD;
begin
INTEGER_TO_S1WORD (W1, LOW);
INTEGER_TO_S1WORD (W2, HI);
W3 := ZEROS1WORD;
PUTFIELD (W3, BNDTYP_START, BNDTYP_LEN, ord(TYPECODE[BNDTYP]) );
PTR := BOUNDTBL.FIRST;
DISP := 0;
FOUND := false;
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W1) and (PTR↑.NEXTPTR↑.CODEWORD = W2) and
(PTR↑.NEXTPTR↑.NEXTPTR↑.CODEWORD = W3) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + 3*WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (BOUNDTBL, W1);
EMIT_S1WORD (BOUNDTBL, W2);
EMIT_S1WORD (BOUNDTBL, W3);
end;
end (*UPD_BOUNDTBL*);
(** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
(**)
procedure INSERT_SHORT_VPA (var OPND : OPERAND;
var V : VPAREC);
(*Insert the VPA into the operand as a short index,
including shift, without changing the rest of
the operand.*)
begin
if not (FITS_SHORT_INDEX(V) and (OPND.X = 1) ) then
ASSERTFAIL('INS_SH_VP001');
if V.VPA.WHICH = RGS then
begin
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else
begin (*short mem*)
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short mem*);
OPND.XW.S := V.VSHIFT
end (*INSERT_SHORT_VPA*);
procedure VPA_OPERAND_NOSHIFT(var OPND : OPERAND; var V : VPAREC);
(*Construct an operand specifying the VPA, including indirection
but not including shift. Operand may be short or extended.*)
begin
if V.VPA.WHICH = RGS then
begin
OPND := EMPTY_OP;
OPND.X := 0;
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else if FITS_SHRT_OFFSET(V.VPA.MEMADR.DSPLMT)
and (V.VPA.MEMADR.LVL > 0) then
begin
if V.VPAIND = IND2 then
ADDR_OPERAND (OPND, 0)
else
begin
OPND := EMPTY_OP;
OPND.X := 0
end;
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short offset*)
else
begin (*extended address*)
if V.VPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, V.VPA.MEMADR.DSPLMT)
else
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [V.VPA.MEMADR.LVL],
V.VPA.MEMADR.DSPLMT);
if V.VPAIND = IND2 then OPND.XW.I := 1
end (*extended address*)
end (*VPA_OPERAND_NOSHIFT*);
procedure FIT_IN_OPERAND (*(var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX)*);
(*Build an operand accessing the quantity described by the datum if
this is possible without emitting any code. Return
TOO_COMPLICATED = true if this was impossible, false
otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if not (FPA.WHICH = MEM) then ASSERTFAIL('FIT_IN_OP001');
if DTYPE = TYPUM then TOO_COMPLICATED := true
else if IS_CONSTANT(STE) then
begin
if not (FINALIND = IND0) then ASSERTFAIL('FIT_IN_OP002');
if DTYPE in [TYPUJ,TYPUB,TYPUC] then
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else if DTYPE in [TYPUI, TYPUK] then
begin
ERROR(WNOT_IMPLEMENTED);
% EXTENDED_IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT);
OPND.F := 1; (*integer sign extend*) \
end
else if DTYPE = TYPUA then
begin
if (FPA.MEMADR.DSPLMT < 0) or
(FPA.MEMADR.DSPLMT > MAXS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
end (*TYPUA*)
else if DTYPE = TYPUQ then
ERROR(WNOT_IMPLEMENTED)
else if DTYPE = TYPUR then
REAL_IMM_OPERAND (OPND, RCNST) (*LCW*)
else if DTYPE = TYPUS then
begin
EXTENDED_REGDISP_OPERAND
(OPND, S1RPC, 0);
OPND.FIXUP := SETFIX;
(*setch*) UPD_SETTBL (OPND.XW.DISP, SCNST);
end (*TYPUS*)
else if DTYPE = TYPUN then
IMM_OPERAND (OPND, NILVAL)
else if not (false) then ASSERTFAIL('FIT_IN_OP003');
end (*constant*)
else if FINALIND = IND0 then
case NVPAS of
(*NVPAS = *) 0:
if FPA.MEMADR.DSPLMT = 0 then
REG_OPERAND (OPND,
LVL_TO_S1REG[FPA.MEMADR.LVL])
else TOO_COMPLICATED := true;
(*NVPAS = *) 1:
if (VPA1.VSHIFT=0) and (FPA=ZEROFPA) then
VPA_OPERAND_NOSHIFT (OPND, VPA1)
else TOO_COMPLICATED := true;
(*NVPAS = *) 2:
TOO_COMPLICATED := true;
end (*case NVPAS of*)
else
begin (*FINALIND > IND0*)
if not ( NVPAS > 0) then ASSERTFAIL('FIT_IN_OP004');
if (FPA.MEMADR.LVL=0) and
(NVPAS=1) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND1 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS
end
else
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1
end
end (*non-level register and displacement*)
else
begin (*more complicated*)
if NVPAS = 1 then
(*NVPAS = 1*)
begin
if not FITS_SHORT_INDEX(VPA1) then
TOO_COMPLICATED := true
else
begin
if FPA.MEMADR.LVL > 0 then
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
end
end (*NVPAS = 1*)
else
(*NVPAS = 2*)
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1)
end
else if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2)
end
else
TOO_COMPLICATED := true;
if FINALIND = IND2 then OPND.XW.I := 1;
end (*more complicated*)
end (*FINALIND > IND0*);
end (*with STK[STE] do*);
end (*FIT_IN_OPERAND*);
(** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
(**)
procedure FIT_ADDRESS_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
(*Build an operand accessing the location whose address is the
quantity (of type address) described by the datum, if this is
possible without emitting any code. Return TOO_COMPLICATED =
true if this was impossible, false otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if (DTYPE=TYPUM) or (FINALIND>IND1) then
TOO_COMPLICATED := true
else
case NVPAS of
(*NVPAS = *) 0:
begin
if not ( FINALIND = IND0) then ASSERTFAIL('FIT_ADDR 001');
if FPA.WHICH = RGS then
REG_OPERAND (OPND, FPA.RGADR)
else if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if (FPA.MEMADR.LVL = 0) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND0 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS;
end
else
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1;
end;
end (*non-level register and displacement*)
else if FITS_SHORT_INDEX(VPA1) then
begin
if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
EXTENDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1
end
else if (FINALIND=IND0) and (FPA=ZEROFPA) and
(VPA1.VSHIFT=0) and (VPA1.VPAIND=IND1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if not ( OPND.X = 1) then ASSERTFAIL('FIT_ADDR 002');
OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true;
end (*NVPAS = 1*);
(*NVPAS = *) 2:
begin
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA1)
and FITS_SHORT_INDEX(VPA2) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else if IS_SIMPLE(VPA2)
and FITS_SHORT_INDEX(VPA1) then
begin
EXTENDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true
end (*NVPAS = 2*)
end (*case NVPAS*)
end (*with STK[STE] do*);
end (*FIT_ADDRESS_IN_OPERAND*);
(** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
(**)
procedure GET_OPERAND (*(var OPND : OPERAND; STE : STKINX)*);
(*Build an operand which accesses the quantity described
by the datum in STK[STE], simplifying the datum as
necessary.*)
var TOO_COMPLICATED : boolean;
begin
if STK[STE].DTYPE = TYPUB then
if STK[STE].BREPRES = BJUMP then BJUMP_TO_BINTVAL (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end;
if STK[STE].DTYPE = TYPUS then (*setch*)
TWIDDLE_OPERAND(OPND, WHICHPART*DOUBLEWORDUNITS);(*setch*)
end (*GET_OPERAND*);
procedure GET_SHORT_OPERAND (var OPND : OPERAND; STE : STKINX);
(*Build a short operand which accesses the quantity described
by the datum, simplifying as necessary.*)
var OPNDR : OPERAND;
begin
GET_OPERAND (OPND, STE);
if OPND.X = 1 then
begin (*generate a MOV*)
FREEDATUMREGS (STE);
if IS_DOUBLE[STK[STE].DTYPE] then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[STK[STE].DTYPE], OPNDR, OPND);
REG_DATUM (STE, STK[STE].CODESTART,
STK[STE].DTYPE, NXTRG);
OPND := OPNDR;
end (*generate a MOV*);
end (*GET_SHORT_OPERAND*);
procedure GET_ADDRESS (var OPND : OPERAND; STE : STKINX);
(*The datum describes a quantity of type address. Build an
operand accessing the location with that address,
simplifying the datum as necessary. (Approximately
GET_OPERAND with one more level of indirection
on the datum) *)
var TOO_COMPLICATED : boolean;
begin
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end
end (*GET_ADDRESS*);
(** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
(**)
procedure MOVE_QUANTITY (*(var DEST : OPERAND; STE : STKINX)*);
(*Emit code to calculate the datum and move to location given
by operand. Do *Not* change datum to reflect move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPUA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if DEST<>SOURCE then
EMITXOP (MOV_X_X[DTYPE], DEST, SOURCE);
end;
end (*MOVE_QUANTITY*);
procedure SLR_QUANTITY (DEST : OPERAND; REGNUM : S1REGISTER;
STE : STKINX);
(*Emit code to calculate the datum and load it into register REGNUM
while saving the previous contents of the register in the word
specified by the operand, using the SLR.'REGNUM' instruction.
Do *Not* change the datum to reflect the move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPUA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (SLRADR_N[REGNUM], DEST, SOURCE);
end
else
EMITXOP (SLR_N[REGNUM], DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
EMITXOP (SLR_N[REGNUM], DEST, SOURCE);
end;
end (*SLR_QUANTITY*);
procedure COERCE_AND_MOVE_QUANTITY (var DEST : OPERAND;
STE : STKINX; RESTYPE : OPNDTYPE);
(*Get the datum to the location specified by the operand,
coercing it to type RESTYPE. Do *Not* change datum to
reflect coercion, but simplification changes may occur.*)
var SOURCE : OPERAND;
MOVEOP : S1OPCODE;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE = TYPUA) and (RESTYPE = TYPUA)
and (FINALIND = IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if not EQUAL_OPERANDS(DEST, SOURCE) or (DTYPE <> RESTYPE)
then
begin (*Use ordinary MOV*)
MOVEOP := MOV_X_Y[RESTYPE, DTYPE];
if MOVEOP = XILLEGAL then
ERROR (WCOERCION_INVALID);
EMITXOP (MOVEOP, DEST, SOURCE);
end;
end (*Use ordinary MOV*);
end (*COERCE_AND_MOVE_QUANTITY*);
procedure STORE(DEST, SOURCE : STKINX);
(*For the future, consider doing STORE without always using
a MOV: (apropos for peephole).*)
(*Emit code to store the operand represented by SOURCE at the
address represented by DEST.*)
var OPND1 (*,OPND2*) : OPERAND;
MOVEOP : S1OPCODE;
begin
MOVEOP := MOV_X_Y[TYP,STK[SOURCE].DTYPE];
if MOVEOP = XILLEGAL then ERROR(WINCOMPATIBLE_TYPES);
(*Possible optimizing heuristic: GET_OPERAND before GET_ADDRESS*)
GET_ADDRESS(OPND1,DEST);
COERCE_AND_MOVE_QUANTITY(OPND1,SOURCE,TYP)
(*or, GET_OPERAND(OPND2,SOURCE); EMITXOP(MOVEOP,OPND1,OPND2)*)
end (*STORE*);
(** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
(**)
procedure ADD_SUB_SINGLE (*(var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX)*);
(*Add together the two singleword operands, optimizing
to INC or DEC if possible.*)
procedure INC_OR_DEC (INC : integer; var OPND : OPERAND);
var OPNDR : OPERAND;
ADDOP : S1OPCODE;
begin
if INC=1 then ADDOP:=XINC_S else ADDOP:=XDEC_S;
if IS_T_REG(OPND) then DEST := OPND.F (*14FEB79 PTZ*)
else
begin
FINDRG; DEST := NXTRG
end;
REG_OPERAND (OPNDR, DEST);
EMITXOP (ADDOP, OPNDR, OPND);
end (*INC_OR_DEC*);
begin (*ADD_SUB_SINGLE*)
if ISSHORTCONST(OPND1) and ((OPND1.F=1) or (OPND1.F=-1)) (*EJG 14FEB79*)
and (ADDOP=XADD_S) then INC_OR_DEC(OPND1.F, OPND2) (*EJG 14FEB79*)
else if ISSHORTCONST(OPND2) and ((OPND2.F=1) or (OPND2.F=-1)) then
if ADDOP=XADD_S then INC_OR_DEC(OPND2.F, OPND1)
else INC_OR_DEC(-OPND2.F, OPND1)
else
ALLOC_AND_EMIT_TOP (DEST, ADDOP, OPND1, OPND2,
false, false, false, STE);
end (*ADD_SUB_SINGLE*);
procedure ADD_TOP_TWO_DATUMS;
(*Add the top two singlewords (integer or address) on the
stack by combining and/or emitting code. Sets DTYPE and
CODESTART in the resultant datum.*)
var COMBINABLE, ADDABLE, TOOMUCH1, TOOMUCH2 : boolean;
CONSTPART : integer;
OPND1, OPND2 : OPERAND;
UNSIMPLE, SIMPLER : STKINX;
DEST : S1REGISTER;
RESTYPE : OPNDTYPE;
begin
COMBINABLE := false;
ADDABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA)
and (STK[TOP].DTYPE<>TYPUM) then
COMBINABLE := true
else if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA)
and (STK[TOP-1].DTYPE<>TYPUM) then
COMBINABLE := true
else
if (STK[TOP].FINALIND=IND0)
and (STK[TOP-1].FINALIND=IND0)
and ( ((STK[TOP].FPA.MEMADR.LVL=0) and (STK[TOP].DTYPE<>TYPUM))
or ((STK[TOP-1].FPA.MEMADR.LVL=0) and (STK[TOP-1].DTYPE<>TYPUM)) )
and (STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) then
COMBINABLE := true
else
begin (*not combinable*)
if (STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) then
begin
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
+ STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end
else
CONSTPART := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
ADDABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else
begin (*Pick one at random*)
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end;
if CONSTPART <> 0 then
begin
if not ((STK[UNSIMPLE].FINALIND = IND0) and
(STK[UNSIMPLE].FPA.MEMADR.DSPLMT = 0) ) then
ASSERTFAIL('ADD_TOP_T001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT := CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*)
until COMBINABLE or ADDABLE;
if (STK[TOP-1].DTYPE=TYPUM) or (STK[TOP].DTYPE=TYPUM) then
RESTYPE := TYPUM
else if (STK[TOP-1].DTYPE=TYPUA) or (STK[TOP].DTYPE=TYPUA) then
RESTYPE := TYPUA
else if (STK[TOP-1].DTYPE=TYPUL) and (STK[TOP].DTYPE=TYPUL) then
RESTYPE := TYPUL
else RESTYPE := TYPUJ;
if ADDABLE then
begin (*ADDABLE*)
if RESTYPE in [TYPUJ, TYPUL] then
begin
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
end (*TYPUJ, TYPUL*);
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, STK[TOP].CODESTART, RESTYPE, DEST);
STK[TOP].DTYPE := RESTYPE;
end (*ADDABLE*)
else
begin (*COMBINABLE*)
if (STK[TOP-1].NVPAS=0) and
(STK[TOP-1].FPA=ZEROFPA) and (STK[TOP-1].DTYPE<>TYPUM) then
STK[TOP-1] := STK[TOP]
else if (STK[TOP].NVPAS=0) and
(STK[TOP].FPA=ZEROFPA) and (STK[TOP].DTYPE<>TYPUM) then
(*Top is zero so just throw it away.*)
else
begin (*Both datums have FINALIND = IND0.*)
if STK[TOP].FPA.MEMADR.LVL<>0 then
STK[TOP-1].FPA.MEMADR.LVL := STK[TOP].FPA.MEMADR.LVL;
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP].FPA.MEMADR.DSPLMT + STK[TOP-1].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
begin
if STK[TOP].NVPAS > 0 then
STK[TOP-1].VPA1 := STK[TOP].VPA1;
if STK[TOP].NVPAS = 2 then
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
else if (STK[TOP-1].NVPAS=1) and (STK[TOP].NVPAS=1) then
STK[TOP-1].VPA2 := STK[TOP].VPA1;
STK[TOP-1].NVPAS := STK[TOP-1].NVPAS+STK[TOP].NVPAS;
end (*Both datums have FINALIND = IND0*);
if RTBUSER = TOP then RTBUSER := TOP-1;
POPTOP;
end (*COMBINABLE*);
end (*ADD_TOP_TWO_DATUMS*);
procedure MULT_SINGLE (var DEST : S1REGISTER;
var OPND1, OPND2 : OPERAND; STE : STKINX);
(*Multiply together the two singleword operands, optimizing to
shift if possible. Note that because of negatives, a right
shift is *Not* equivalent to a divide.*)
(*Note - at present this procedure only considers short
constants for possible translations into shifts.
When real S1WORDs make it easier to consider extended
constants, this should be improved.*)
var SHIFTDIST : integer;
OPNDI : OPERAND;
begin
if ISSHORTCONST(OPND1) then
begin
SHIFTDIST := POWER2 (OPND1.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND2, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else if ISSHORTCONST(OPND2) then
begin
SHIFTDIST := POWER2 (OPND2.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP
(DEST, XSHFA_LF_S, OPND1, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end (*MULT_SINGLE*);
procedure SIMPLIFY (*(STE : STKINX)*);
(*By doing a very small amount of work - about one instruction -
simplify the datum so that it is closer to fitting in an
operand. Repeated calls to this procedure are guaranteed to
eventually get it so it will fit. One more call will get the
quantity into a register if it is not a constant: beyond this
point it is an error to call SIMPLIFY.*)
var OPND : OPERAND;
UNKNOWN_LOC : integer;
procedure ADD_VPAS;
(*Build operands for VPA1 and VPA2, both of which have zero
shifts. Generate an ADD instruction to combine the two
into a simple register. This is guaranteed not to
completely sum the parts of the datum if the datum is
an address.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((VPA1.VSHIFT=0) and (VPA2.VSHIFT=0)) then
ASSERTFAIL('ADD_VPAS 001');
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ])) then
ASSERTFAIL('ADD_VPAS 002');
VPA_OPERAND_NOSHIFT (OPND1, VPA1);
VPA_OPERAND_NOSHIFT (OPND2, VPA2);
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND1, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
FREEVPARGUNLESS (VPA2, DEST);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*ADD_VPAS*);
procedure FPA_LVL_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction to
combine this with the FPA level, replacing them
by a simple register. This is guaranteed not to
completely sum the parts of the datum.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FPA.MEMADR.LVL > 0) and
((DTYPE=TYPUA) or (FINALIND>IND0)) ) then
ASSERTFAIL('FPLVL_VPA001');
REG_OPERAND (OPND2, LVL_TO_S1REG [FPA.MEMADR.LVL] );
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
FPA.MEMADR.LVL := 0;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*FPA_LVL_PLUS_VPA1*);
procedure FPA_DSPLMT_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction
to add this VPA to the FPA displacement,
resulting in a single register VPA.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND=IND0) and (DTYPE=TYPUJ)) then
ASSERTFAIL('FDSP_VPA 001');
IMM_OPERAND (OPND2, FPA.MEMADR.DSPLMT);
ADD_SUB_SINGLE (DEST, XADD_S, OPND, OPND2, STE);
FREEVPARGUNLESS (VPA1, DEST);
FPA.MEMADR.DSPLMT := 0;
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST
end (*with STK[STE]*)
end (*FPA_DSPLMT_PLUS_VPA1*);
procedure VPA_FPA_FINALIND;
(*The datum consists of a short-index VPA and an FPA,
with some value of FINALIND. Completely simplify it
using address arithmetic into a single register.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if IS_SIMPLE(VPA1) and (DTYPE<>TYPUM)
and (FPA.MEMADR.LVL = 0)
and FITS_SHRT_OFFSET (FPA.MEMADR.DSPLMT) then
begin (*non-level register and short offset*)
if FINALIND = IND2 then
begin
ADDR_OPERAND (OPND2, 0);
OPND2.REG := VPA1.VPA.RGADR;
OPND2.F := FPA.MEMADR.DSPLMT div WORDUNITS;
FREEDATUMREGS (STE);
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end
else
begin
REGDISP_OPERAND (OPND2, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin MOVEOP := XMOV_A; FINDRG; end
else
begin
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*non-level register and short offset*)
else
begin
if not (((DTYPE in [TYPUA,TYPUM]) or (FINALIND>IND0))
and (NVPAS=1) and FITS_SHORT_INDEX(VPA1) ) then
ASSERTFAIL('VP_FP_FIN001');
if FPA.MEMADR.LVL > 0 then
EXTENDED_REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else if DTYPE <> TYPUM then
ADDR_OPERAND (OPND2, FPA.MEMADR.DSPLMT)
else
begin
EXTENDED_REGDISP_OPERAND (OPND2,
S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPUA;
end;
INSERT_SHORT_VPA (OPND2, VPA1);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X[DTYPE];
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*VPA_FPA_FINALIND*);
procedure SHORT_AND_REG (var VSHORT, VREG : VPAREC);
(*Combine the two VPAs and the FPA displacement into
a simple register by address arithmetic. Allow
for the possibility that this may completely sum
the parts; in that case include FINALIND in the
operand to completely simplify the datum. Note
that the FPA level may be implicit due to DTYPE=TYPUM.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPUA,TYPUM]) or (FINALIND > IND0) ) then
ASSERTFAIL('SHORT®001');
EXTENDED_REGDISP_OPERAND (OPND2,
VREG.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND2, VSHORT);
FPA.MEMADR.DSPLMT := 0;
FREEVPAREG (VPA1);
FREEVPAREG (VPA2);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
if (FINALIND=IND0) or
(FPA.MEMADR.LVL>0) or (DTYPE=TYPUM) then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X [DTYPE];
if IS_DOUBLE [DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
FINALIND := IND0;
end;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*SHORT_AND_REG*);
procedure CALCULATE_FPA;
(*Combine the FPA level and displacement by address
arithmetic. The level may be implicitly PC-relative
by virtue of the datum's being TYPUM. Assume no
VPAs and FINALIND = IND0.*)
var OPND1, OPND2 : OPERAND;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPUA,TYPUM]) and
(NVPAS=0) and (FINALIND=IND0) ) then
ASSERTFAIL('CALC_FPA 001');
FINDRG;
REG_OPERAND (OPND1, NXTRG);
if DTYPE <> TYPUM then
REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
begin
EXTENDED_REGDISP_OPERAND
(OPND2, S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPUA;
end;
FPA := ZEROFPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
EMITXOP (XMOV_A, OPND1, OPND2);
end (*with STK[STE]*)
end (*CALCULATE_FPA*);
procedure DEREF_AND_SHIFT (var V : VPAREC);
(*Build an operand from the VPA neglecting shift and
emit a SHIFT instruction to reduce the VPA to
a simple register.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ]) ) then
ASSERTFAIL('DEREFSHFT001');
VPA_OPERAND_NOSHIFT (OPND1, V);
IMM_OPERAND (OPND2, V.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND1, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (V, DEST);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := DEST;
end (*DEREF_AND_SHIFT*);
procedure SHIFT_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit a SHIFT instruction to
reduce VPA1 to a simple register.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ]) ) then
ASSERTFAIL('SHIFTVPA 001');
IMM_OPERAND (OPND2, VPA1.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND, OPND2,
false, false, false, STE);
FREEVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*SHIFT_VPA1*);
procedure DEREF (var V : VPAREC; var OPND : OPERAND);
(*OPND describes the VPA, posibly with additional
indirection. Generate a MOV using this operand,
which will reduce the VPA to a simple register without
completely simplifying the datum. (Both these
conditions are assured by the caller.)*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (XMOV_S_S, OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG
end (*DEREF*);
procedure DEREF_TO_END (var V : VPAREC;
var OPND : OPERAND; DTYPE : OPNDTYPE);
(*OPND describes the VPA, possibly with some extra
indirection. Generate a MOV using this operand to
reduce the VPA to a simple register. This operation
is guaranteed to completely simplify the datum, which
is of type DTYPE.*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
if IS_DOUBLE [DTYPE] then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[DTYPE], OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG;
end (*DEREF_TO_END*);
begin (*SIMPLIFY*)
with STK[STE] do
begin
if FPA.WHICH = RGS then
ERROR (WINDEXING_IN_PARMS);
if (FINALIND=IND0) and not(DTYPE in [TYPUA,TYPUM]) then
begin (*no address arithmetic allowed*)
if FPA.MEMADR.LVL <> 0 then ASSERTFAIL('SIMPLIFY 001');
case NVPAS of
(*NVPAS = *) 0:
if not ( false) then ASSERTFAIL('SIMPLIFY 002');
(*NVPAS = *) 1:
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
SHIFT_VPA1 (OPND)
else if FPA.MEMADR.DSPLMT <> 0 then
FPA_DSPLMT_PLUS_VPA1 (OPND)
else
begin
if not ( not IS_SIMPLE(VPA1) ) then
ASSERTFAIL('SIMPLIFY 003');
DEREF_TO_END (VPA1, OPND, DTYPE);
end
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*no address arithmetic allowed*)
else
begin (*address arithmetic allowed. In fact, to
prevent an address from looking like an
indirect address pointer, address arithmetic
is required if a non-address operation
would completely simplify the datum.*)
case NVPAS of
(*NVPAS = *) 0:
begin
if not ((DTYPE = TYPUM) or
(FPA.MEMADR.LVL>0) and (FPA.MEMADR.DSPLMT<>0) ) then
ASSERTFAIL('SIMPLIFY 004');
CALCULATE_FPA
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if not (not ((DTYPE<>TYPUM) and (FPA=ZEROFPA) and
IS_SIMPLE(VPA1) ) ) then
ASSERTFAIL('SIMPLIFY 005');
if FITS_SHORT_INDEX (VPA1) then
VPA_FPA_FINALIND
else
begin (*requires extended address*)
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
begin
if (FPA=ZEROFPA) and (DTYPE<>TYPUM) then
ERROR (WINDEX_WITHOUT_BASE);
SHIFT_VPA1 (OPND)
end
else if (FPA.MEMADR.LVL>0)
and (FPA.MEMADR.DSPLMT<>0) then
FPA_LVL_PLUS_VPA1 (OPND)
else if (DTYPE=TYPUM) or (FPA<>ZEROFPA) then
DEREF (VPA1, OPND)
else
begin (*dereference some or all the way*)
if not (OPND.X = 1) then ASSERTFAIL('SIMPLIFY 006');
if (FINALIND>IND0) and (OPND.XW.I=0) then
begin
OPND.XW.I := 1;
FINALIND := pred(FINALIND);
end;
if FINALIND = IND0 then
DEREF_TO_END (VPA1, OPND, DTYPE)
else
begin
DEREF (VPA1, OPND);
VPA1.VPAIND := IND2;
FINALIND := pred(FINALIND)
end;
end (*dereference*)
end (*requires extended address*)
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
SHORT_AND_REG (VPA2, VPA1)
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
SHORT_AND_REG (VPA1, VPA2)
else if (DTYPE<>TYPUM) and (FPA=ZEROFPA) then
begin
(*be careful not to finish simplification
with integer arithmetic.*)
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if not IS_SIMPLE(VPA1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
DEREF (VPA1, OPND)
end
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
begin
VPA_OPERAND_NOSHIFT (OPND, VPA2);
DEREF (VPA2, OPND)
end
end (*be careful...*)
else if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*address arithmetic allowed*)
end (*with STK[STE]*);
if TR_SIMP then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := NEXT_INSTRUCTION(OLDINSTREC);
end;
OLDINSTREC := NEWINSTREC;
WRITELN (OUTPUT, ' Datum simplified');
PRINTDATUM (STE)
end;
end (*SIMPLIFY*);
(** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXWRD1 PRINTXWRD2 PRINTOPERAND PRINTREG PRINT_SIGNED_OCTAL PRINTSHORTOP **)
(**)
procedure DISASSEMBLE(*(var CURPC : integer; IPTR : A_CODEREC)*);
(*This procedure disassembles and prints a single S1 instruction
starting at the word pointed to by IPTR, using CURPC as the
location of that instruction, and updates CURPC to indicate the
location of the next instruction.*)
var NXTPC : integer;
CURS1OPC : S1OPCODE;
ICW : S1WORD;
XPTR1, XPTR2, TPTR : A_CODEREC;
T : TWOBITS;
SLOC : CHAR10;
I, J : integer; (*LCW*)
ANS : CHAR12;
(* Output format :
.........1.........2.........3.........4.........5.........6.........7
locationxx : instrwordxxx opcodemnemonicx <operands>
xopnd1wordxx (if any)
xopnd2wordxx (if any)
*)
procedure PRINTPTRADDR (CPTR : A_CODEREC); (*15JAN79 PTZ*)
var CPI : CODEREC_PTRINT;
begin
CPI.PTR := CPTR;
WRITE(OUTPUT,'(',CPI.INT:8,')')
end (*PRINTPTRADDR*);
procedure PRINTLOC;
var SLOC : CHAR10;
begin
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
PRINTPTRADDR(IPTR); (*15JAN79 PTZ*)
CVOS_10(SLOC,CURPC);
WRITE(OUTPUT,SLOC,' : ')
end (*PRINTLOC*);
procedure PRINTIWORD;
var SWORD : CHAR12;
begin
CVOS_S1WORD_12(SWORD,ICW);
WRITE(OUTPUT,SWORD,' ')
end (*PRINTIWORD*);
procedure PRINTXWRD1;
var SWORD : CHAR12;
begin
(* if XPTR1 = nil test made before call ALS*)
CVOS_S1WORD_12(SWORD,XPTR1↑.CODEWORD);
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
WRITE(OUTPUT,' '); (*space taken by ptr addr - PTZ*)
WRITELN(OUTPUT,' ',SWORD)
end (*PRINTXWRD1*);
procedure PRINTXWRD2;
var SWORD : CHAR12;
begin
(* if XPTR2 = nil test made before call ALS*)
CVOS_S1WORD_12(SWORD,XPTR2↑.CODEWORD);
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
WRITE(OUTPUT,' '); (*space taken by ptr addr - PTZ*)
WRITELN(OUTPUT,' ',SWORD)
end (*PRINTXWRD2*);
procedure PRINTOPERAND(var SHORTWORD : S1WORD;
XWORDPTR : A_CODEREC;
SHORTSTARTBIT : S1BITNUM);
(*Disassemble and print one S1 operand whose short part
starts at SHORTSTARTBIT in SHORTWORD and whose extended
part (if any) is in the CODEREC at XWORDPTR↑. *)
var I, J, K, KSIGN, KWID : integer;
OPNDX : BIT;
OPNDREG : S1REGISTER;
OPNDF : MINSHORTOFFSET..MAXSHORTOFFSET;
XWORD : S1WORD;
SWORD : CHAR12;
procedure PRINTREG(R : S1REGISTER);
var
ANS : CHAR2;
I, J : 1..2;
begin
J := 1;
if R = S1RTA then WRITE(OUTPUT,'%RTA')
else if R = S1RTB then WRITE(OUTPUT,'%RTB')
else
begin
WRITE (OUTPUT,'%');
ANS[2] := chr(ord('0') + (R mod 8));
R := R div 8;
if R > 0 then ANS[1] := chr(ord('0') + R)
else J := J + 1;
for I := J to 2 do WRITE(OUTPUT,ANS[I]);
end
end (*PRINTREG*);
procedure PRINT_SIGNED_OCTAL(K : integer); (*30dec78 ALS*)
begin
IF K < 0 then
begin
K := - K;
WRITE (OUTPUT,'-');
end;
CVOS_12(ANS,K);
J := 1;
while ANS[J] = ' ' do J := J + 1;
for I := J to 12 do WRITE(OUTPUT,ANS[I]);
end (*PRINT_SIGNED_OCTAL*);
procedure PRINTSHORTOP;
begin
if OPNDREG = 0 then PRINTREG(OPNDF)
else if OPNDREG = 1 then
begin (*short constant*)
WRITE(OUTPUT,'#');
PRINT_SIGNED_OCTAL(OPNDF); (*31DEC78 ALS*)
end (*short constant*)
else if OPNDREG = 2 then
begin
if not (false) then
ASSERTFAIL('PRINTSHOR001')
end
else
begin (*short indexed*)
if not ((3 <= OPNDREG) and (OPNDREG <= LASTS1REG)) then
ASSERTFAIL('PRINTSHOR002');
PRINT_SIGNED_OCTAL(OPNDF); (*31DEC78 ALS*)
WRITE(OUTPUT,'*4'); (*FASM requires this 3JAN79 ALS*)
WRITE(OUTPUT,'('); (*31dec78 ALS*)
PRINTREG(OPNDREG);
WRITE(OUTPUT,')');
end (*short indexed*)
end (*PRINTSHORTOP*);
begin (*PRINTOPERAND*)
OPNDX := GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDX_START,
OPNDX_LEN);
OPNDREG := GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDREG_START,
OPNDREG_LEN);
OPNDF := GETSIGNEDFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,
OPNDF_LEN);
if OPNDX = 1 then
begin (*extended operand*)
if not (XWORDPTR <> nil) then ASSERTFAIL('PRINTOPER001');
XWORD := XWORDPTR↑.CODEWORD;
if (OPNDREG = 1) and (OPNDF <> 0) then
begin (*long constant*)
if not ((OPNDF>=1) and (OPNDF<=3)) then ASSERTFAIL('PRINTOPER002');
KSIGN := GETSIGNEDFIELD(XWORD,0,6);
WRITE(OUTPUT,'#',CHR(124)); (*LCW*)
if ((KSIGN=0) or (KSIGN=-1)) and (OPNDF = 1) then
begin (*print signed octal*) (*30dec78 ALS*)
K := GETSIGNEDFIELD(XWORD,WORDBITS-(BITS_ON_COMP_MACH-1),
BITS_ON_COMP_MACH - 1);
if not (((KSIGN=0) and (K>=0))
or ((KSIGN=-1) and (K<0))) then
ASSERTFAIL('PRINTOPER003');
PRINT_SIGNED_OCTAL(K); (*31DEC78 ALS*)
end (*print signed octal*)
else
begin (*print in octal*)
CVOS_S1WORD_12(SWORD,XWORD);
J := 1;
while SWORD[J] = ' ' do J := J + 1;
for I := J to 12 do WRITE(OUTPUT,SWORD[I]);
if OPNDF <> 1 then
begin
WRITE(OUTPUT,'F',OPNDF:1); (*???*)
end;
end; (*print in octal*) (*LCW*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
end (*long constant*)
else
begin (*extended address*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
if GETFIELD(XWORD,XWI_START,XWI_LEN) = 1 then
begin (*indirect bit*)
WRITE(OUTPUT,'@'); (*LCW*)
end (*indirect bit*);
if GETFIELD(XWORD,XWV_START,XWV_LEN) = 1 then
begin (*variable base*)
K := GETSIGNEDFIELD(XWORD,XWDISP_START,XWDISP_LEN);
(* write in octal always*) (*29dec78 ALS*)
PRINT_SIGNED_OCTAL(K);
WRITE(OUTPUT,'(');
PRINTREG(GETFIELD(XWORD,XWREG_START,XWREG_LEN));
WRITE(OUTPUT,')');
end (*variable base*)
else
begin (*fixed base*)
K := GETSIGNEDFIELD(XWORD,XWADDR_START,XWADDR_LEN); (*ALS*)
PRINT_SIGNED_OCTAL(K); (*30DEC78 ALS*)
end (*fixed base*);
WRITE(OUTPUT,CHR(124)); (*LCW*)
if (OPNDREG=1) and (OPNDF=0) then
(*short-zero mode: no index to print*)
else
begin (*print index*)
WRITE(OUTPUT,'('); (*LCW*)
PRINTSHORTOP;
WRITE(OUTPUT,')'); (*LCW*)
K := GETFIELD(XWORD,XWS_START,XWS_LEN);
if K <> 0 then
begin (*print shift*)
WRITE(OUTPUT,'↑'); (*LCW*)
PRINT_SIGNED_OCTAL(K); (*31DEC78 ALS*)
end (*print shift*);
end (*print index*)
end (*extended address*)
end (*extended operand*)
else
begin (*short operand*)
if not (XWORDPTR = nil) then ASSERTFAIL('PRINTOPER004');
PRINTSHORTOP
end (*short operand*)
end (*PRINTOPERAND*);
begin (*DISASSEMBLE*)
CURS1OPC := GETS1OPCODE(IPTR);
XPTR1 := nil; XPTR2 := nil;
ICW := IPTR↑.CODEWORD;
NXTPC := CURPC;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
if not JUMPS_CONCRETIZED and TR_PEEPHOLE then (*15JAN79 PTZ...*)
begin
PRINTLOC;
PRINTIWORD;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*)
CVOS_10(SLOC,GETFIELD(ICW,FAKEOPND_START,FAKEOPND_LEN));
J := 1;
while SLOC[J] = ' ' do J := J+1;
for I := J to 10 do WRITE(OUTPUT,SLOC[I]);
WRITELN(OUTPUT)
end
(*else ignore it*); (*...15JAN79 PTZ*)
VTOP, VXOP, VSOP:
begin
PRINTLOC;
PRINTIWORD;
TPTR := IPTR↑.NEXTPTR;
NXTPC := NXTPC + WORDUNITS;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR2 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR1 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*) (*ALS*)
if OPFORMAT[CURS1OPC] = VTOP then
begin (*VTOP*)
T := GETFIELD(ICW,T_START,T_LEN);
if T = 1 then
begin (* OP1 = RTA, OP2 *)
PRINTOPERAND(ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,',%RTA,'); (*LCW*)
PRINTOPERAND(ICW,XPTR2,OPND2_START)
end (* OP1 = RTA, OP2 *)
else
begin
if T = 2 then WRITE(OUTPUT,'%RTA,') (*LCW*)
else if T = 3 then WRITE(OUTPUT,'%RTB,') (*LCW*)
(*else T = 0*);
PRINTOPERAND(ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,',');
PRINTOPERAND(ICW,XPTR2,OPND2_START)
end
end (*VTOP*)
else
begin (*VXOP, VSOP*)
PRINTOPERAND(ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,',');
PRINTOPERAND(ICW,XPTR2,OPND2_START);
if OPFORMAT[CURS1OPC] = VSOP then
begin (*VSOP*)
WRITE(OUTPUT,','); (*LCW*)
if JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
begin
CVOS_10(SLOC,CURPC + WORDUNITS*GETSIGNEDFIELD
(ICW,SKP_START,SKP_LEN));
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end
else
PRINTPTRADDR(TPTR↑.CODEPTR); (*15JAN79 PTZ*)
end (*VSOP*)
end (*VXOP, VSOP*);
WRITELN(OUTPUT);
if XPTR2 <> nil then PRINTXWRD2; (*3JAN79 ALS*)
if XPTR1 <> nil then PRINTXWRD1; (*3JAN79 ALS*)
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
PRINTLOC;
PRINTIWORD;
TPTR := IPTR↑.NEXTPTR;
NXTPC := NXTPC + WORDUNITS;
if ((JUMPS_CONCRETIZED
and (GETFIELD(ICW,PR_START,PR_LEN) = 0))
or (not JUMPS_CONCRETIZED))
and (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR2 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin
NXTPC := NXTPC + WORDUNITS;
XPTR1 := TPTR;
TPTR := TPTR↑.NEXTPTR
end;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*) (*ALS*)
PRINTOPERAND(ICW,XPTR1,OPND1_START);
WRITE(OUTPUT,','); (*LCW*)
if JUMPS_CONCRETIZED then
begin
if (GETFIELD(ICW,PR_START,PR_LEN) = 1) then
begin (*PC relative*)
CVOS_10(SLOC,CURPC + WORDUNITS*GETSIGNEDFIELD
(ICW,J_START,J_LEN));
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end (*PC relative*)
else
begin (*print OPND2*)
PRINTOPERAND(ICW,XPTR2,OPND2_START)
end (*print OPND2*)
end
else
PRINTPTRADDR(TPTR↑.CODEPTR); (*15JAN79 PTZ*)
WRITELN(OUTPUT);
if XPTR2 <> nil then PRINTXWRD2; (*3JAN79 ALS*)
if XPTR1 <> nil then PRINTXWRD1; (*3JAN79 ALS*)
end (*VJOP*)
end (*case*);
ASMPC := NXTPC;
CURPC := NXTPC
end (*DISASSEMBLE*);
(** OBJECT_MODULE_SEGMENT_CLASS: CODE_CONCRETIZER CONC_PASS1 INSERT_S1LOC JMPX_TO_JMPA_OPT **)
(**)
procedure CODE_CONCRETIZER;
(*Concretize the MAINCODE code in three passes. On pass 1, insert
fake S1LOC instructions at each jump or skip destination. On
pass 2, compute a final PC value as code is passed, filling the
current PC value into each S1LOC instruction. Also, fix up all
PC relative extended operands by subtracting the PC value from
their displacements. On pass 3, fix up all jump and skip
instructions by inserting final PC relative references.*)
var
IPTR, NXTIPTR, JPTR, TPTR, LASTPTR : A_CODEREC;
NXTPC, TPC, PASS2_MAXPC : 0..MAXS1LOC;
CURS1OPC : S1OPCODE;
ICW : S1WORD;
NWORDS_BEFORE_S1LOCS, NON_S1LOC_FAKEOPS : integer; (*28APR79 PTZ*)
PROC_WDS_REMOVED : integer; (*28APR79 PTZ*)
procedure CONC_PASS1; (*PBK*)
(* first pass over the code inserts S1LOC fake instructions
at the destination of each skip or jump.
peephole optimization of jumps to jumps is done during
this pass. *)
procedure INSERT_S1LOC (BEFORE, JMPORSKPPTR : A_CODEREC); (*PBK*)
(*28APR79 PTZ*)
(* This inserts an S1LOC fake instruction before the CODEREC
pointed to by BEFORE. To preserve pointers this is done
by moving the CODEREC in BEFORE to a new CODEREC and replacing
it with the S1LOC. If there was already an S1LOC there, change
ptrs so that each S1LOC marking this as a jmp or skp destination
will be pointed to by exactly one jmp or skp *) (*28APR79 PTZ*)
var
AFTER, TPTR : A_CODEREC;
begin
if BEFORE <> nil then
(* if GETS1OPCODE(BEFORE) <> XS1LOC then PBK*)
begin
NEWCODEREC(AFTER);
AFTER↑ := BEFORE↑;
BEFORE↑.NEXTPTR := AFTER;
BEFORE↑.CODEWORD := ZEROS1WORD;
PUTFIELD(BEFORE↑.CODEWORD,
OPCODE_START,OPCODE_LEN,
HARDOPCODE[XS1LOC]);
PUTFIELD(BEFORE↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN,
S1LOCUNDEF);
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
if GETS1OPCODE(AFTER) = XS1LOC then (*28APR79 PTZ...*)
begin
TPTR := AFTER_LAST_XWORD(JMPORSKPPTR);
TPTR↑.CODEPTR := AFTER
end; (*...28APR79 PTZ*)
end (* if BEFORE <> nil then *);
end (* procedure INSERT_S1LOC *);
procedure JMPX_TO_JMPA_OPT ( INSTLOC : A_CODEREC ); (*PBK*)
(* This procedure takes the jump instruction at INSTLOC
and follows the chain (if any) of its destination
through any JMPAs to make the destination the final
destination of the chain of JMPAs (if any).
This saves just a little bit of time, but it makes
the code more esthetically pleasing [huh?] *)
var
JMP_TO_JMPA : boolean;
DESTPTR, DESTINSTPTR, INSTDESTPTR : A_CODEREC;
begin
if GETFIELD(INSTLOC↑.CODEWORD,OPND2X_START,OPND2X_LEN) = 0 then
begin
DESTPTR := JUMPSKIPDEST(INSTLOC);
repeat (* until not JMP_TO_JMPA *)
JMP_TO_JMPA := false;
if DESTPTR <> nil then
begin
DESTINSTPTR := AFTER_FAKEOPS(DESTPTR);
if DESTINSTPTR <> nil then
begin
if GETS1OPCODE(DESTINSTPTR) = XJMPA then
begin
DESTPTR := JUMPSKIPDEST(DESTINSTPTR);
JMP_TO_JMPA := true;
J_TO_J_CNT := J_TO_J_CNT + 1;
end
(* if GETS1OPCODE(DESTINSTPTR) = XJMPA then *)
end (* if DESTINSTPTR <> nil then *)
end (* if DESTPTR <> nil then *)
until not JMP_TO_JMPA;
(* fix jump or skip destination of start of jump chain *)
INSTDESTPTR := AFTER_LAST_XWORD(INSTLOC);
INSTDESTPTR↑.CODEPTR := DESTPTR;
end;
(* else
this JMPX has an extended destination word and hence is
too complicated to chain - specifically it may be an
indexed jump into a jump table (in this case the jumpdest
ptr points to the first jump in the table - DON'T chain
this since it won't in general actually execute through
the first jump) *)
end (* JMPX_TO_JMPA_OPT *);
begin (* CONC_PASS1 *)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT,'----------------------------- ;START OF ',
CURPROCXN.NAM,' ',CURPROC);
WRITELN(OUTPUT,'before S1LOC insertion pass :');
WRITELN(OUTPUT,'-----------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
IPTR := MAINCODE.FIRST;
NON_S1LOC_FAKEOPS := 0;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] in [VJOP,VSOP] then
begin
if (OPFORMAT[CURS1OPC] = VJOP) and not NO_JMPX_TO_JMPA_FLG then
(* attempt to optimize jumps to JMPAs.
don't try to do skips to JMPAs, since
that would almost certainly make the skip
not reach, and we can't fix that up now. *)
JMPX_TO_JMPA_OPT(IPTR);
INSERT_S1LOC(JUMPSKIPDEST(IPTR),IPTR); (*28APR79 PTZ*)
end (* if OPFORMAT[CURS1OPC] in [VJOP,VSOP] then *)
else if (OPFORMAT[CURS1OPC] = VFAKEOP) and (CURS1OPC <> XS1LOC) then
NON_S1LOC_FAKEOPS := NON_S1LOC_FAKEOPS + 1; (*28APR79 PTZ*)
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil do*);
if MAINCODE.LAST <> nil then
while MAINCODE.LAST↑.NEXTPTR <> nil do
MAINCODE.LAST := MAINCODE.LAST↑.NEXTPTR;
end (*CONC_PASS1*);
(** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER SKIP_JMPA_OPT COLLAPSE_MOV_OPT **)
(**)
procedure PEEPHOLE_OPTIMIZER (*(var CHANGES : boolean)*) ; (*PTZ*)
(*28APR79 PTZ*)
var PREV_IPTR : A_CODEREC;
WDS_REMOVED_THIS_PASS : integer;
CHANGES : boolean;
procedure SKIP_JMPA_OPT (SKIPPTR : A_CODEREC; SKIPPC : integer);
var JMPAPTR, L2PTR, TPTR, L1PTR : A_CODEREC;
L2PC : 0..MAXS1LOC;
SKIP_WORDS, JMPA_WORDS : 1..3; (*create a TYPE*)
JMPOFF : integer;
STILL_LOOKING : boolean;
begin
JMPAPTR := AFTER_NONS1LOC_FAKEOPS(NEXT_INSTRUCTION(SKIPPTR));
if JMPAPTR <> nil then
begin
if (GETS1OPCODE(JMPAPTR) = XJMPA)
and (GETFIELD(JMPAPTR↑.CODEWORD,PR_START,PR_LEN) <> 1) then
begin (*not in jump table*)
L1PTR := JUMPSKIPDEST(SKIPPTR);
L2PTR := JUMPSKIPDEST(JMPAPTR);
if not ((GETS1OPCODE(L1PTR) = XS1LOC)
and (GETS1OPCODE(L2PTR) = XS1LOC)) then
ASSERTFAIL('SKIP_JMPA001');
TPTR := NEXT_INSTRUCTION(JMPAPTR);
STILL_LOOKING := true;
while (TPTR <> nil) and STILL_LOOKING do
begin
STILL_LOOKING :=
(OPFORMAT[GETS1OPCODE(TPTR)] = VFAKEOP) and
(TPTR <> L1PTR);
if STILL_LOOKING then
TPTR := NEXT_INSTRUCTION(TPTR)
end;
if TPTR = L1PTR then
begin (*the SKP skips around the JMPA*)
SKIP_WORDS := INSTR_WORDS(SKIPPTR,SKIPPC);
JMPA_WORDS := INSTR_WORDS(JMPAPTR,
SKIPPC+SKIP_WORDS*WORDUNITS);
L2PC := GETFIELD(L2PTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
if L2PC <> S1LOCUNDEF then
begin (*backward skip or ≥ 2nd pass*)
JMPOFF := (L2PC - SKIPPC) div WORDUNITS;
if JMPOFF > 0 then
JMPOFF := JMPOFF
- (JMPA_WORDS + WDS_REMOVED_THIS_PASS)
end
else
begin (*forward skip: 1st pass only*)
JMPOFF := INSTR_WORDS(SKIPPTR,SKIPPC);
TPTR := NEXT_INSTRUCTION(JMPAPTR);
while (JMPOFF <= MAXSKPOFFSET) and (TPTR <> L2PTR)
and (TPTR <> nil) do
begin
JMPOFF := JMPOFF
+ INSTR_WORDS(TPTR,SKIPPC + JMPOFF*WORDUNITS);
TPTR := NEXT_INSTRUCTION(TPTR)
end;
end;
if (MINSKPOFFSET <= JMPOFF)
and (JMPOFF <= MAXSKPOFFSET) then
begin
(* SKP.COND.X Y,Z,L1 -> SKP.OPPCOND.X Y,Z,L2
JMPA L2
L1: S1LOC
(MINSKPOFFSET <= L2-SKP <= MAXSKPOFFSET)
There is 1 S1LOC for each time a place is used as a
destination, so we can optimize across the boundary
when the last one goes away *)
JMPAS_REMOVED_FROM_SKIPS :=
JMPAS_REMOVED_FROM_SKIPS + 1;
INVERT_SKIP(SKIPPTR);
TPTR := AFTER_LAST_XWORD(SKIPPTR);
TPTR↑.CODEPTR := L2PTR;
DELETE_INSTR(SKIPPTR,JMPAPTR,WDS_REMOVED_THIS_PASS);
DELETE_INSTR(SKIPPTR,L1PTR,WDS_REMOVED_THIS_PASS)
end
end (*if TPTR = L1PTR then*)
end
end (*if JMPAPTR <> nil then*)
end (*SKIP_JMPA_OPT*);
procedure COLLAPSE_MOV_OPT (PREVPTR, MOVPTR : A_CODEREC;
MOV_PRECISION : S1PRECISION);
var MOV_OPND1, MOV_OPND2, T : integer;
PREVS1OPC : S1OPCODE;
begin
MOV_OPND2 := S1OPND_TEMPLOC(MOVPTR,OPND2_START);
PREVS1OPC := GETS1OPCODE(PREVPTR);
if (MOV_OPND2 >= 0) and (DEST_PRECISION[PREVS1OPC] = MOV_PRECISION)
and COLLAPSIBLE_OP[PREVS1OPC] then
begin
if PEEP_LOC_IS_FREE(NEXT_INSTRUCTION(MOVPTR),MOV_OPND2) then
(*We now know that the source of the MOV.X.X is
no longer going to be used, and that the instruction
preceding the MOV.X.X is a collapsible one.
Now look for certain patterns in the collapsible inst*)
begin
MOV_OPND1 := GETFIELD(MOVPTR↑.CODEWORD,OPND1_START,OPND1_LEN);
if OPFORMAT[PREVS1OPC] = VXOP then
begin
if S1OPND_TEMPLOC(PREVPTR,OPND1_START) = MOV_OPND2 then
begin
(* collapsibleXOP.X.W TREG,Y -> collapsibleXOP.X.W Z,Y
MOV.X.X Z,TREG
REGFREED TREG REGFREED TREG *)
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
INSERT_OPND1(PREVPTR,MOV_OPND1,
PTR_OPNDXWD(MOVPTR,OPND1_START),
WDS_REMOVED_THIS_PASS);
DELETE_INSTR(PREVPTR,MOVPTR,WDS_REMOVED_THIS_PASS)
end
end (*XOP*)
else
begin
if not (OPFORMAT[PREVS1OPC] = VTOP) then
ASSERTFAIL('COLLAPSE 001');
T := GETFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN);
if (T = 1)
and (S1OPND_TEMPLOC(PREVPTR,OPND1_START) = MOV_OPND2) then
begin
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
if S1OPNDS_EQUAL(PREVPTR,OPND2_START,
MOVPTR,OPND1_START) then
begin
(* TOP.X TREG,RTA,Y -> reverseTOP.X Y,RTA
MOV.X.X Y,TREG
REGFREED TREG REGFREED TREG *)
INVERT_OPCODE(PREVPTR);
PUTFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN,0);
SWAP_OPERANDS(PREVPTR); (*gives Y,TREG*)
PUTFIELD(PREVPTR↑.CODEWORD,OPND2F_START,
OPND2F_LEN,S1RTA); (*gives Y,RTA*)
DELETE_INSTR(PREVPTR,MOVPTR,WDS_REMOVED_THIS_PASS)
end
else
begin
(* TOP.X TREG,RTA,Y -> TOP.X Z,RTA,Y
MOV.X.X Z,TREG
REGFREED TREG REGFREED TREG *)
INSERT_OPND1(PREVPTR,MOV_OPND1,
PTR_OPNDXWD(MOVPTR,OPND1_START),
WDS_REMOVED_THIS_PASS);
DELETE_INSTR(PREVPTR,MOVPTR,WDS_REMOVED_THIS_PASS)
end
end (*(T=1) and (PREV OPND1=MOV_OPND2)*)
else if ((T=2) and (MOV_OPND2=S1RTA))
or ((T=3) and (MOV_OPND2=S1RTB)) then
begin
if S1OPNDS_EQUAL(PREVPTR,OPND1_START,
MOVPTR,OPND1_START) then
begin
(* TOP.X RTAorRTB,Y,Z -> TOP.X Y,Z
MOV.X.X Y,RTAorRTB
REGFREED RTAorRTB REGFREED RTAorRTB *)
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
PUTFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN,0);
DELETE_INSTR(PREVPTR,MOVPTR,WDS_REMOVED_THIS_PASS)
end
else if S1OPNDS_EQUAL(PREVPTR,OPND2_START,
MOVPTR,OPND1_START) then
begin
(* TOP.X RTAorRTB,Z,Y -> reverseTOP.X Y,Z
MOV.X.X Y,RTAorRTB
REGFREED RTAorRTB REGFREED RTAorRTB *)
MOVS_COLLAPSED := MOVS_COLLAPSED + 1;
INVERT_OPCODE(PREVPTR);
PUTFIELD(PREVPTR↑.CODEWORD,T_START,T_LEN,0);
SWAP_OPERANDS(PREVPTR);
DELETE_INSTR(PREVPTR,MOVPTR,WDS_REMOVED_THIS_PASS)
end
end
end (*TOP*)
end (*if FOUND then*)
end
end (*COLLAPSE_MOV_OPT*);
(** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER **)
(**)
begin (*PEEPHOLE_OPTIMIZER*)
(* The first pass of the peephole optimizer removes or simplifies
any instructions that it can *)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before peephole pass 1 :');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
WDS_REMOVED_THIS_PASS := 0;
IPTR := MAINCODE.FIRST;
PREV_IPTR := nil;
CURPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if (OPFORMAT[CURS1OPC] = VXOP) and (PREV_IPTR <> nil) then
begin
if not NO_COLLAPSE_MOV_FLG then
begin
if CURS1OPC = XMOV_S_S then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1S)
else if CURS1OPC = XMOV_Q_Q then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1Q)
else if CURS1OPC = XMOV_D_D then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1D)
else if CURS1OPC = XMOV_H_H then
COLLAPSE_MOV_OPT(PREV_IPTR,IPTR,S1H)
end
end;
if (OPFORMAT[CURS1OPC] <> VFAKEOP) or (CURS1OPC = XS1LOC) then
PREV_IPTR := IPTR;
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil do*);
PROC_WDS_REMOVED := PROC_WDS_REMOVED + WDS_REMOVED_THIS_PASS;
(* The rest of the peephole optimizer - at most MAXPEEPASSES -
does a straightforward collapse of skips around JMPAs that
are short enough to be a skip alone. A small amount of testing
shows that the first pass gets about 90 percent of the cases
and the second pass gets a few percent more, etc.
We don't combine this optimization with the previous group
because keeping track of the PC while deleting instructions
and pieces of instructions is difficult *)
PASS2_MAXPC := SEG_EP_RELPC + WORDUNITS*(NWORDS_BEFORE_S1LOCS -
(NON_S1LOC_FAKEOPS + PROC_WDS_REMOVED)); (*28APR79 PTZ*)
(*this will work as long as MAINCODE.NWORDS is an upper
bound on the number of words of instructions emitted*)
CHANGES := true;
PEEP_PASSES := 0;
while CHANGES and (PEEP_PASSES < MAXPEEP_PASSES) do
begin
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before peephole pass ',PEEP_PASSES+2:2,':');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
WDS_REMOVED_THIS_PASS := 0;
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
BIGJUMPS := (((PASS2_MAXPC-SEG_EP_RELPC) div WORDUNITS) > MAXJPROFFSET)
and BIGJUMPS; (*28APR79 PTZ*)
(* don't let BIGJUMPS go from false to true - now set initially
in CODE_CONCRETIZER *)
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] = VFAKEOP then
begin
if CURS1OPC = XS1LOC then
PUTFIELD(IPTR↑.CODEWORD,FAKEOPND_START,FAKEOPND_LEN,CURPC)
end
else
begin
if (OPFORMAT[CURS1OPC] = VSOP) and not NO_SKIP_JMPA_FLG then
SKIP_JMPA_OPT(IPTR,CURPC)
end;
CURPC := CURPC + INSTR_WORDS(IPTR,CURPC)*WORDUNITS;
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil do*);
CHANGES := WDS_REMOVED_THIS_PASS <> 0;
PASS2_MAXPC := CURPC;
PROC_WDS_REMOVED := PROC_WDS_REMOVED + WDS_REMOVED_THIS_PASS;
PEEP_PASSES := PEEP_PASSES + 1
end;
end (*PEEPHOLE_OPTIMIZER*);
(** OBJECT_MODULE_SEGMENT_CLASS: CONC_PASS3 PASS3PCRELFIX INSERT_NOP **)
(**)
procedure CONC_PASS3; (*PTZ*)
var SKPOFF : MINSKPOFFSET..MAXSKPOFFSET;
JMPOFF : integer;
TOPND : OPERAND;
FORCE2 : boolean;
procedure PASS3PCRELFIX(SHORTWORD : S1WORD; (*EJG*)
var XWORD : S1WORD;
SHORTSTARTBIT : S1BITNUM);
(*Examine the extended non-constant S1 operand in SHORTWORD
and XWORD whose short part starts at SHORTSTARTBIT in
SHORTWORD. If it is PC relative, fix it up by subtracting
the current PC value from the displacement.*)
var VBIT : BIT;
begin
if not (
GETFIELD
(SHORTWORD,SHORTSTARTBIT+OPNDX_START,OPNDX_LEN) = 1) then
ASSERTFAIL('PASS3PCRE001');
VBIT := GETFIELD(XWORD,XWV_START,XWV_LEN);
if ((GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN)=0)
and
(GETFIELD(SHORTWORD,SHORTSTARTBIT+OPNDF_START,OPNDF_LEN)=S1RPC))
or ((VBIT = 1)
and
(GETFIELD(XWORD,XWREG_START,XWREG_LEN) = S1RPC))
then
if VBIT = 1 then
PUTFIELD(XWORD,XWDISP_START,XWDISP_LEN,
GETSIGNEDFIELD(XWORD,XWDISP_START,XWDISP_LEN)
- CURPC)
else
PUTFIELD(XWORD,XWADDR_START,XWADDR_LEN,
GETSIGNEDFIELD(XWORD,XWADDR_START,XWADDR_LEN)
- CURPC);
end (*PASS3PCRELFIX*);
procedure INSERT_NOP;
(*Insert a single word no-op in the code immediately following
the word at LASTPTR, updating NXTPC (and MAINCODE.NWORDS).*)
var OPND : OPERAND;
begin
INSERTXOP(LASTPTR,XNOP,UNUSED_OP,UNUSED_OP); (*LCW*)
NXTPC := NXTPC + WORDUNITS
end (*INSERT_NOP*);
begin (*CONC_PASS3*)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before final concretizer:');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
(* BIGJUMPS := ((PASS2_MAXPC div WORDUNITS) > MAXJPROFFSET) 17JAN79 EJG*)
while IPTR <> nil do
begin
NXTIPTR := NEXT_INSTRUCTION(IPTR);
NXTPC := CURPC;
CURS1OPC := GETS1OPCODE(IPTR);
if OPFORMAT[CURS1OPC] = VFAKEOP then
begin
if CURS1OPC = XS1LOC then
begin (* extra begin-end added 1JAN79 ALS*)
if not (GETFIELD(IPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN) = CURPC) then
ASSERTFAIL('CODE_CONC002')
end
end
else (*not VFAKEOP*)
begin
ICW := IPTR↑.CODEWORD;
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
if not (*PTZ*)
((GETFIELD(ICW,OPND2F_START,OPND2F_LEN) > 0) and (*PTZ*)
(GETFIELD(ICW,OPND2REG_START,OPND2REG_LEN) = 1)) (*PTZ*)
then (*PTZ*)
PASS3PCRELFIX(ICW,TPTR↑.CODEWORD,OPND2_START); (*EJG*)
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
if not (*PTZ*)
((GETFIELD(ICW,OPND1F_START,OPND1F_LEN) > 0) and (*PTZ*)
(GETFIELD(ICW,OPND1REG_START,OPND1REG_LEN) = 1)) (*PTZ*)
then (*PTZ*)
PASS3PCRELFIX(ICW,TPTR↑.CODEWORD,OPND1_START); (*EJG*)
TPTR := TPTR↑.NEXTPTR
end;
if OPFORMAT[CURS1OPC] = VSOP then
begin (*any VSOP*)
JPTR := TPTR↑.CODEPTR;
if JPTR <> nil then
begin
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('CODE_CONC003');
TPC := GETFIELD(JPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC004');
SKPOFF := (TPC-CURPC) div WORDUNITS;
if not ((MINSKPOFFSET<=SKPOFF)
and (SKPOFF<=MAXSKPOFFSET)) then
ASSERTFAIL('CODE_CONC005');
PUTFIELD(IPTR↑.CODEWORD,SKP_START,SKP_LEN,SKPOFF)
end
end (*any VSOP*)
else if OPFORMAT[CURS1OPC] = VJOP then
begin (*any VJOP*)
JPTR := TPTR↑.CODEPTR;
LASTPTR := TPTR;
FORCE2 := (GETFIELD(ICW,PR_START,PR_LEN) = 1)
(*force two-word jump*);
if JPTR = nil then
begin (*no JUMPDEST: leave alone except FORCE2*)
TPC := CURPC; (*bookkeeping: not forward*) (*PTZ*)
PUTFIELD (IPTR↑.CODEWORD, PR_START, PR_LEN, 0);
end (*no JUMPDEST*)
else
begin
if not (GETS1OPCODE(JPTR) = XS1LOC) then
ASSERTFAIL('CODE_CONC006');
TPC := GETFIELD(JPTR↑.CODEWORD,
FAKEOPND_START,FAKEOPND_LEN);
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC007');
JMPOFF := (TPC-CURPC) div WORDUNITS;
if (MINJPROFFSET<=JMPOFF)and(JMPOFF<=MAXJPROFFSET)
and(GETFIELD(ICW,OPND2X_START,OPND2X_LEN)=0) then
begin (*PR-style jump*)
PUTFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN,1);
PUTFIELD(IPTR↑.CODEWORD,J_START,J_LEN,JMPOFF)
end (*PR-style jump*)
else
begin (*non PR-style jump*)
PUTFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN,0);
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN)=0 then
begin (*build an extended OPND2*)
if not (BIGJUMPS)
then ASSERTFAIL('CODE_CONC010');
NXTPC := NXTPC + WORDUNITS;
NEWCODEREC(TPTR);
TPTR↑.NEXTPTR := IPTR↑.NEXTPTR;
IPTR↑.NEXTPTR := TPTR;
(*EJG 17JAN79*) EXTENDED_REGDISP_OPERAND(TOPND, S1RPC, -CURPC);
(*EJG 17JAN79
TOPND := ZERO_OP;
TOPND.X := 1; TOPND.F := 0; TOPND.REG := 1;
TOPND.XW.V := 1; TOPND.XW.REG := S1RPC;
TOPND.XW.DISP := -CURPC;
EJG 17JAN79*)
BUILD_CW_OPERAND(IPTR↑.CODEWORD,
TPTR,TOPND,OPND2_START);
MAINCODE.NWORDS := MAINCODE.NWORDS + 1
end (*build an extended OPND2*);
TPTR := IPTR↑.NEXTPTR;
(*get pointer to extended OPND2*)
PUTFIELD(TPTR↑.CODEWORD,
XWDISP_START, XWDISP_LEN,
GETSIGNEDFIELD(TPTR↑.CODEWORD,
XWDISP_START,XWDISP_LEN)
+ TPC)
end (*non PR-style jump*);
end (*valid JUMPDEST*);
if FORCE2 then
begin (*force two-word jump*)
while NXTPC-CURPC < 2*WORDUNITS do
INSERT_NOP;
if not (NXTPC-CURPC = 2*WORDUNITS) then
ASSERTFAIL('CODE_CONC008')
(*else was already > 2 words*)
end (*force two-word jump*)
else
begin (*normal jump*)
if TPC > CURPC then
begin (*forward jump*)
if(GETFIELD(IPTR↑.CODEWORD,PR_START,PR_LEN)=1)
and BIGJUMPS then
(*We assumed extended OPND2 since it was
forward, but managed to emit PR-style -
so insert NOP to keep PC straight*)
INSERT_NOP
end (*forward jump*)
end (*normal jump*)
end (*any VJOP*)
end (*not VFAKEOP*);
IPTR := NXTIPTR;
CURPC := NXTPC
end (*while IPTR <> nil do*);
if not (PASS2_MAXPC = CURPC) then ASSERTFAIL('CODE_CONC009');
end (*CONC_PASS3*);
begin (*CODE_CONCRETIZER*) (*28APR79 PTZ...*)
PROC_WDS_REMOVED := 0;
NWORDS_BEFORE_S1LOCS := MAINCODE.NWORDS;
CONC_PASS1;
BIGJUMPS := (NWORDS_BEFORE_S1LOCS - NON_S1LOC_FAKEOPS) > MAXJPROFFSET;
(*this will work as long as MAINCODE.NWORDS is an upper
bound on the number of words of instructions emitted*)
S1LOCS_INSERTED := true;
PEEPHOLE_OPTIMIZER (* (PASS2_NEEDED) *) ;
(* if PASS2_NEEDED then CONC_PASS2; *)
CONC_PASS3;
JUMPS_CONCRETIZED := true;
INSTR_WDS_REMOVED := INSTR_WDS_REMOVED + PROC_WDS_REMOVED;
end (*CODE_CONCRETIZER*); (*...28APR79 PTZ*)
(** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
(**)
procedure INIT_SEGMENT;
var R : S1REGISTER;
G : S1GBL;
H : integer;
S1X : S1Q..S1D;
begin
NEW(OLDNP);
MAINCODE := EMPTYCODELIST;
S1LOCS_INSERTED := false; (*28APR79 PTZ*)
JUMPS_CONCRETIZED := false;
NEWCODEREC(NEWINSTREC);
STRINGAREA := EMPTYCODELIST;
NXTSTRDISP := 0;
STRINGFIXLIST := EMPTYCODELIST;
TOP := BOT-1;
for R := FIRSTS1REG to LASTS1REG do
begin
RISFREE[R] := true;
RPWORD[R] := RSINGLE; (*PBK*)
end;
for G := FIRSTS1GBL to LASTS1GBL do
begin
GISFREE[G] := true;
end;
MINTMPS1REG := MINPARS1REG;
for H := 0 to LBLHTSIZEM1 do
LBLHASHTAB[H] := nil;
EVALSAVE.SIZE := 0;
EVALSAVE.FIXLIST := EMPTYCODELIST;
EVALSAVE.NEGFIXLIST := EMPTYCODELIST;
STACKFRAME.SIZE := 0; (*als/peg 25jul79..*)
STACKFRAME.FIXLIST := EMPTYCODELIST;
STACKFRAME.NEGFIXLIST := EMPTYCODELIST; (*...als/peg 25jul79*)
NEG_SHIFT_FIXLIST := EMPTYCODELIST;
MSTTOP := 0;
MSTSTK[MSTTOP].EVALSAVESTART := 0;
REALTBL := EMPTYCODELIST;
SETTBL := EMPTYCODELIST;
BOUNDTBL := EMPTYCODELIST;
LOCTBL := EMPTYCODELIST;
REALFIXLIST := EMPTYCODELIST;
SETFIXLIST := EMPTYCODELIST;
BOUNDFIXLIST := EMPTYCODELIST;
PROCTBL.NPROCS := 0;
PROCTBL.FIRST := nil;
end (*INIT_SEGMENT*);
procedure GEN_SEGMENT;
const
MAXTXTBUFNWORDS = 4; (*for TXT records to fit in 80 columns*)
var
PTR, IPTR, NXTIPTR, TPTR, OPLOC : A_CODEREC;
VAL, DSP : integer;
I : 0..LBLHTSIZEM1;
LPTR : A_LBLHASHENT;
PPTR : A_PROCENT;
NXTPC, MAXPC : integer;
PITPC : integer; (*address of PIT in segment*)
S1PC : integer;
NREF, INX : integer;
CURS1OPC : S1OPCODE;
ICW, W, W1, W2 : S1WORD;
TXTBUF : array [1..MAXTXTBUFNWORDS] of S1WORD;
TXTBUFNWORDS : 0..MAXTXTBUFNWORDS;
TXTBUFFSTADR : S1RELADR;
TXTBUFNXTADR : S1RELADR;
RADR : S1RELADR;
SSTR : CHAR4;
SLOC : CHAR10;
SWORD : CHAR12;
S1X : S1Q..S1D;
procedure DISASM(NXTCP : INTEGER; PTR : A_CODEREC); (*28DEC78 ALS*)
begin
CVOS_10(SLOC,NXTPC);
WRITE(OUTPUT,SLOC,' : ');
ICW := PTR↑.CODEWORD;
CVOS_S1WORD_12(SWORD,ICW);
WRITE(OUTPUT,SWORD,' ');
end (* DISASM *);
procedure DISASM2(PTR : A_CODEREC); (*28DEC78 ALS*)
var
K, KWID : INTEGER;
begin
ICW := PTR↑.CODEWORD;
K := GETFIELD(ICW,WORDBITS-(BITS_ON_COMP_MACH-1),
BITS_ON_COMP_MACH - 1);
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.');
WRITELN(OUTPUT);
end (* DISASM2 *);
procedure FIXDISP(WORDLOC : A_CODEREC; FIXVAL : integer);
(*Fix up the extended word addressed by WORDLOC by adding the
FIXVAL to the displacement.*)
var DSP : integer;
begin
DSP := GETSIGNEDFIELD(WORDLOC↑.CODEWORD,
XWDISP_START,XWDISP_LEN);
DSP := DSP + FIXVAL;
if (DSP > MAXS1DISP) or (DSP < MINS1DISP) then
ERROR(WINVALID_DISPLACEMENT)
else
PUTFIELD(WORDLOC↑.CODEWORD,XWDISP_START,XWDISP_LEN,DSP)
end (*FIXDISP*);
procedure OPEN_SEGMENT(NESD, NTXT, NESR, NRLD : integer);
(*Prepare to output the segment. NESD is the number of
external symbols which will be defined. NTXT is the number
of words of TXT which will be output. NESR is the number of
external symbols which will be referenced. NRLD is the
number of words which will be relocated. If any of these
parameters is not known exactly, specify -1.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_SEGMENT*);
procedure CLOSE_SEGMENT;
(*Close segment output.*)
begin
(* The following SIN record should be output when S-1 runtimes
exist for finding compilation date and time - see LDI-5:
WRITELN(PRR,'SIN COMPILER 0 ',compilation date,' ',
compilation time,' ',SOPA_NAME:8,' ',SOPA_VERSION:2,
' ',SOPA_MODLEVEL:2); *) (*23JUL79 PTZ*)
WRITELN(PRR,'EOM ',CURPROCXN.NAM,' WRITER-ID: ',
SOPA_ID); (*temporarily*) (*23JUL79 PTZ*)
end (*CLOSE_SEGMENT*);
procedure CLEAROUT_TXTBUF;
(*Clear out the TXTBUF by outputting a TXT record if any text
is contained therein. Count the words output.*) (*LCW*)
var I : 1..MAXTXTBUFNWORDS;
S_FSTADR : CHAR12;
S_TXTBFW : CHAR12;
begin
WORD_CNT := WORD_CNT + TXTBUFNWORDS; (*LCW*)
if TXTBUFNWORDS > 0 then
begin
CVOS_12(S_FSTADR,TXTBUFFSTADR);
WRITE(PRR,'TXT ',1:8,' ',S_FSTADR,' ',TXTBUFNWORDS:2);
for I := 1 to TXTBUFNWORDS do
begin
CVOS_S1WORD_12(S_TXTBFW,TXTBUF[I]);
WRITE(PRR,' ',S_TXTBFW);
end;
WRITELN(PRR);
TXTBUFNWORDS := 0
end
end (*CLEAROUT_TXTBUF*);
procedure OPEN_TXT;
(*Prepares to output the TXT part of the module.*)
begin
TXTBUFNWORDS := 0
end (*OPEN_TXT*);
procedure CLOSE_TXT;
(*Closes off all pending TXT part output.*)
begin
CLEAROUT_TXTBUF
end (*CLOSE_TXT*);
procedure OUT_TXT(var ADR : S1RELADR; WORD : S1WORD);
(*Outputs the word WORD as part of a TXT record, to be loaded
at address ADR. Increments ADR by WORDUNITS to prepare for
next word.*)
begin
if (TXTBUFNWORDS >= MAXTXTBUFNWORDS) or (ADR <> TXTBUFNXTADR)
then
CLEAROUT_TXTBUF;
if TXTBUFNWORDS = 0 then
begin
TXTBUFFSTADR := ADR;
TXTBUFNXTADR := ADR
end;
TXTBUFNWORDS := TXTBUFNWORDS + 1;
TXTBUF[TXTBUFNWORDS] := WORD;
ADR := ADR + WORDUNITS;
TXTBUFNXTADR := ADR
end (*OUT_TXT*);
(** OBJECT_MODULE_SEGMENT_CLASS: OPEN_SEG CLOSE_SEG OUT_SEG OPEN_ESD CLOSE_ESD OUT_ESD OPEN_ESR CLOSE_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
(**)
procedure OPEN_SEG;
(*Prepares to output the SEG part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_SEG*);
procedure CLOSE_SEG;
(*Closes off all pending SEG part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_SEG*);
procedure OUT_SEG(LSNAM : ALFA; STYP : ZSEGTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
SLEN : integer; SACMOD : CHAR17);
(*Outputs a SEG entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and length SLEN.*)
var S_SADR, S_SLEN : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
CVOS_12(S_SLEN, SLEN);
WRITELN(PRR,'SEG ',SNAM:8,' ',ZSEGTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',S_SLEN,' ',SACMOD);
end (*OUT_SEG*);
procedure OPEN_ESD;
(*Prepares to output the ESD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESD*);
procedure CLOSE_ESD;
(*Closes off all pending ESD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_ESD*);
procedure OUT_ESD(LSNAM : ALFA; STYP : ZESDTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
INX : ESDINDEX);
(*Outputs an ESD entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'ESD ',SNAM:8,' ',ZESDTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',INX:8);
end (*OUT_ESD*);
procedure OPEN_ESR;
(*Prepares to output the ESR part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESR*);
procedure CLOSE_ESR;
(*Closes off all pending ESR part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_ESR*);
procedure OUT_ESR(LSNAM : ALFA; STYP : ZESRTYPE;
INX : ESRINDEX);
(*Outputs an ESR entry for symbol SNAM of type STYP and index
INX.*)
var SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
WRITELN(PRR,
'ESR ',SNAM:8,' ',ZESRTYPE_TO_CHARS[STYP]:4,' ',INX:8)
end (*OUT_ESR*);
procedure OPEN_RLD;
(*Prepares to output the RLD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_RLD*);
procedure CLOSE_RLD;
(*Closes off all pending RLD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_RLD*);
procedure OUT_RLD(LSNAM : ALFA; IXFLAG : ZESDESRSEG;
SOPR : ZOPR; SEGINX : ESDINDEX;
SADR : S1RELADR; INX : ZINDEX);
(*Outputs an RLD entry for symbol SNAM of type IXFLAG, operation
SOPR, segment index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'RLD ',SNAM:8,' ',ZIXFLAG_TO_CHAR[IXFLAG]:1,
' ',ZOPR_TO_CHARS[SOPR]:2,' ',SEGINX:8,
' ',S_SADR,' ',INX:8)
end (*OUT_RLD*);
begin (*GEN_SEGMENT*)
PTR := EVALSAVE.FIXLIST.FIRST;
while PTR <> nil do
begin
FIXOPND2(PTR↑.CODEPTR,EVALSAVE.SIZE);
PTR := PTR↑.NEXTPTR
end;
PTR := EVALSAVE.NEGFIXLIST.FIRST;
VAL := - EVALSAVE.SIZE;
while PTR <> nil do
begin
FIXOPND2(PTR↑.CODEPTR,VAL);
PTR := PTR↑.NEXTPTR
end;
PTR := STACKFRAME.FIXLIST.FIRST;
while PTR <> nil do
begin
FIXOPND2(PTR↑.CODEPTR,STACKFRAME.SIZE);
PTR := PTR↑.NEXTPTR
end;
PTR := NEG_SHIFT_FIXLIST.FIRST;
while PTR <> nil do
begin
OPLOC := PTR_OPNDXWD(PTR↑.CODEPTR,OPND2_START);
if not (OPLOC<>nil) then ASSERTFAIL('GEN_SEGME001');
DSP := GETSIGNEDFIELD(OPLOC↑.CODEWORD,
XWDISP_START,XWDISP_LEN);
DSP := (-DSP) * DALIGNMUL;
PUTFIELD(OPLOC↑.CODEWORD,XWDISP_START,XWDISP_LEN,DSP);
PTR := PTR↑.NEXTPTR
end;
(*Check for undefined labels*)
for I := 0 to LBLHTSIZEM1 do
begin
LPTR := LBLHASHTAB[I];
while LPTR <> nil do
begin
if not LPTR↑.DEFINED then
begin
ERRINT1 := LPTR↑.LBLNUM;
ERROR(WL_LPTR_LBLNUM_UNDEFINED)
end;
LPTR := LPTR↑.NEXTPTR
end;
end (*for I := 0 to LBLHTSIZEM1*);
if TOP <> BOT-1 then
ERROR (WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT);
if MSTTOP <> 0 then
ERROR (WMST_WITHOUT_CUP_IN_LAST_SEGMENT);
CODE_CONCRETIZER;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
(*Resolve string, real, set literals...*)
PTR := STRINGFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + STRINGAREA.NWORDS * WORDUNITS;
PTR := REALFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + REALTBL.NWORDS * WORDUNITS;
PTR := SETFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + SETTBL.NWORDS * WORDUNITS;
PTR := BOUNDFIXLIST.FIRST;
while PTR <> nil do
begin
FIXDISP(PTR↑.CODEPTR,CURPC);
PTR := PTR↑.NEXTPTR
end;
CURPC := CURPC + BOUNDTBL.NWORDS * WORDUNITS;
PITPC := CURPC;
if DEBUG then
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
CURS1OPC := GETS1OPCODE(IPTR);
ICW := IPTR↑.CODEWORD;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
if CURS1OPC = XPLOC then
begin (*might emit PLOCs also*)
INTEGER_TO_S1WORD(W,S1PC);
EMIT_S1WORD(LOCTBL,W)
end
(*else ignore it*);
VTOP, VXOP, VSOP:
begin
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
S1PC := S1PC + WORDUNITS
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
S1PC := S1PC + WORDUNITS;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
S1PC := S1PC + WORDUNITS;
if (GETFIELD(ICW,PR_START,PR_LEN) = 0) and
(GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
S1PC := S1PC + WORDUNITS
end (*VJOP*)
end (*case*);
IPTR := NEXT_INSTRUCTION(IPTR);
end (*while IPTR <> nil*);
CURPC := CURPC + LOCTBL.NWORDS * WORDUNITS
end (*if DEBUG*);
if ASM then
begin
WRITELN(OUTPUT,'************************** ;START OF ',
CURPROCXN.NAM,' ',CURPROC);
WRITELN(OUTPUT,'************************** ;WRITER-ID: ',
SOPA_ID); (*23JUL79 PTZ*)
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE(S1PC,IPTR);
IPTR := NEXT_INSTRUCTION(IPTR)
end (*while IPTR <> nil*);
(*To report all strings in .PS1*) (*22DEC78 ALS*)
PTR := STRINGAREA.FIRST;
NXTPC := ASMPC;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,'ASCII /');
CVCHR_S1WORD_4(SSTR,ICW);
WRITE(OUTPUT,SSTR,'/');
WRITELN(OUTPUT);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for STRINGAREA*);
PTR := REALTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;REAL LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for REALTBL*);
PTR := SETTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;SET LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for SETTBL*);
PTR := BOUNDTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;BOUND LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for BOUNDTBL*);
PTR := LOCTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
ICW := PTR↑.CODEWORD;
WRITE(OUTPUT,' ;LOC LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for LOCTBL*);
WRITELN(OUTPUT);
WRITE(OUTPUT,chr(12)) (*12 dec = 14 oct = FF (form feed) *)
end (*if ASM then*);
IPTR := MAINCODE.FIRST; (*LCW*)
while IPTR <> nil do (*LCW*)
begin (*LCW*)
S1OP_CNT[GETS1OPCODE(IPTR)] := S1OP_CNT[GETS1OPCODE(IPTR)] + 1; (*LCW*)
IPTR := NEXT_INSTRUCTION(IPTR); (*LCW*)
end; (*LCW*)
(*** Output the segment to the loader file... ***)
MAXPC := CURPC;
NREF := 0; PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
NREF := NREF + PPTR↑.FIXLIST.NWORDS;
PPTR := PPTR↑.NEXTPTR
end;
OPEN_SEGMENT(1,MAXPC div WORDUNITS,PROCTBL.NPROCS,2*NREF);
(*Output the SEG entries...*)
OPEN_SEG;
OUT_SEG(CURPROCXN.NAM,ZIS,1,SEG_START_RELPC,MAXPC-SEG_START_RELPC,
'IN RA ');
CLOSE_SEG;
(*Output the ESD entries...*)
OPEN_ESD;
OUT_ESD(CURPROCXN.NAM,ZIN,1,SEG_START_RELPC,1);
CLOSE_ESD;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
(*Output the TXT entries...*)
OPEN_TXT;
CURPC := SEG_START_RELPC;
ZSYMBOL_TO_S1WORDS(W1,W2,CURPROCXN.NAM);
OUT_TXT(CURPC,W1);
OUT_TXT(CURPC,W2);
W := ZEROS1WORD;
if DEBUG then PUTFIELD(W,0,1,1);
PUTFIELD(W,1,5,LVL_TO_S1REG[CURLVL]);
OUT_TXT(CURPC,W);
INTEGER_TO_S1WORD(W,PITPC);
OUT_TXT(CURPC,W);
IPTR := MAINCODE.FIRST;
if not (CURPC = SEG_EP_RELPC) then ASSERTFAIL('GEN_SEGME002');
while IPTR <> nil do
begin
NXTIPTR := NEXT_INSTRUCTION(IPTR);
NXTPC := CURPC;
CURS1OPC := GETS1OPCODE(IPTR);
(* abort if an illegal opcode has been generated *) (*NOV78 PTZ...*)
if not (CURS1OPC <> XILLEGAL) then
ASSERTFAIL('GEN_SEGME003'); (*...NOV78 PTZ*)
ICW := IPTR↑.CODEWORD;
case OPFORMAT[CURS1OPC] of
VFAKEOP:
(*Ignore it*);
VTOP, VXOP, VSOP:
begin
OUT_TXT(CURPC,ICW);
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1 then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
OUT_TXT(CURPC,ICW);
NXTPC := NXTPC + WORDUNITS;
TPTR := IPTR↑.NEXTPTR;
if (GETFIELD(ICW,PR_START,PR_LEN) = 0)
and (GETFIELD(ICW,OPND2X_START,OPND2X_LEN) = 1) then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end;
if GETFIELD(ICW,OPND1X_START,OPND1X_LEN) = 1 then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
OUT_TXT(CURPC,TPTR↑.CODEWORD);
TPTR := TPTR↑.NEXTPTR
end
end (*VJOP*)
end (*case*);
IPTR := NXTIPTR;
if not (CURPC = NXTPC) then ASSERTFAIL('GEN_SEGME003')
end (*while IPTR <> nil do*);
PTR := STRINGAREA.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := REALTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := SETTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := BOUNDTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = PITPC) then ASSERTFAIL('GEN_SEGME004');
PTR := LOCTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = MAXPC) then ASSERTFAIL('GEN_SEGME005');
CLOSE_TXT;
(*Output the ESR entries...*)
OPEN_ESR;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
OUT_ESR(PPTR↑.NAME,ZIR,INX);
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLOSE_ESR;
(*Output the RLD entries...*)
OPEN_RLD;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
PTR := PPTR↑.FIXLIST.FIRST;
while PTR <> nil do
begin
RADR := -GETSIGNEDFIELD(PTR↑.CODEPTR↑.CODEWORD,
XWADDR_START,XWADDR_LEN) (*EJG*)
+ SEG_EP_RELPC + WORDUNITS;
(*A procedure reference operand starts out with a
displacement of SEG_EP_RELPC. During concretization,
it has the PC value subtracted from it. Thus
-GETSIGNEDFIELD(...)+SEG_EP_RELPC is the PC value of
the JSR instruction (distance from the beginning of
the module), and so adding WORDUNITS yields the PC
value of the operand itself.*)
OUT_RLD( PPTR↑.NAME,ZESR, ZPLUS,1,RADR,INX);
(*add callee seg addr*)
OUT_RLD(CURPROCXN.NAM,ZESD,ZMINUS,1,RADR, 1);
(*subtract caller seg addr*)
PTR := PTR↑.NEXTPTR
end;
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLOSE_RLD;
CLOSE_SEGMENT;
OLDINSTREC := nil; (*So debugging class will survive.*)
NEWINSTREC := nil;
TOP := BOT-1;
MSTTOP := 0;
(* RELEASE(OLDNP); *) (*X10S1*)
DISPOSE(OLDNP); (*X10S1*)
end (*GEN_SEGMENT*);
(** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
(**)
procedure SAVE_PARMREGS;
(*Archive all the parmregs to the parmreg save area
in order to make all variables uniformly addressable,
or in order to free the registers.*)
(* Shortened to use MOVMS_N 5 DEC 78 ALS *)
var LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
begin
with CURPROCSPEC do
begin
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if LASTPREG >= 0 then
begin
REGDISP_OPERAND (OPND1, DISPLAY, R_OFFSET);
REG_OPERAND (OPND2, PRM_TO_S1REG [0]);
EMITXOP (MOVMS_N[LASTPREG+1], OPND1, OPND2);
end;
end;
PREGS_ARCHIVED := true;
end (*SAVE_PARMREGS*);
procedure RESTORE_PARMREGS;
(*Restore the parmregs from the save area.*)
(* Shortened to use MOVMS_N 5 Dec 78 ALS *)
var LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
begin
with CURPROCSPEC do
begin
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if LASTPREG >= 0 then
begin
REG_OPERAND (OPND1, PRM_TO_S1REG [0]);
REGDISP_OPERAND (OPND2, DISPLAY, R_OFFSET);
EMITXOP (MOVMS_N[LASTPREG+1], OPND1, OPND2);
end;
end;
PREGS_ARCHIVED := false;
end (*RESTORE_PARMREGS*);
procedure CALLSTANDARD;
(*Figure out which standard procedure is being called, load its
arguments into the proper places, and generate the call.*)
var OPNDR, OPND1, OPND2, OPNDI1, OPNDI2 : OPERAND;
CSP : P_STANDARDPROC;
RESCODESTART : A_CODEREC;
RESTYPE : OPNDTYPE;
SKIPLOC : A_CODEREC;
SKIP1LOC, SKIP2LOC : A_CODEREC; (*BNDTRPKLU*)
FAKE_REF : boolean;
FAKE_PARMREG : S1REGISTER;
FAKE_PARMDISP : integer;
procedure GENCALL (BOTTOMPARM : STKINX);
(*Load the stack (except for parms)
to prevent side effects, and generate the JSR instruction,
with fixup information.*)
var CSPNAM : NAMEREC;
OPNDR, OPND2 : OPERAND;
begin
REG_OPERAND (OPNDR, LVL_TO_S1REG[2]);
EXT_REGADDR_OPERAND (OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
CSPNAM.NAM := '$PCSP '; (*can be optimized to 'OWN' var*)
CSPNAM.LEN := 8;
CSPNAM.NAM[6] := NAM1.NAM[1];
CSPNAM.NAM[7] := NAM1.NAM[2];
CSPNAM.NAM[8] := NAM1.NAM[3];
UPD_PROCTBL (OPND2.FIXPTR, CSPNAM.NAM);
LOADSTACKEXCEPT (BOTTOMPARM, TOP);
EMITJOP (XJSR, 0, OPNDR, OPND2, nil);
end (*GENCALL*);
procedure ONE_ARG (ARG : STKINX; TYP : OPNDTYPE);
(*Load RTB with the argument, coercing to type TYP as needed.*)
begin
if not RISFREE[S1RTB] and (RTBUSER <> ARG) then
MOVE_AND_FREE_RTB;
COERCE_AND_MOVE_QUANTITY (OPNDRTB, ARG, TYP);
FREEDATUMREGS (ARG);
end (*ONE_ARG*);
procedure TWO_SINGLE_ARGS (ARG1, ARG2 : STKINX;
TYP1, TYP2 : OPNDTYPE);
(*Load RTB with two singleword arguments, coercing as needed.*)
var OPNDR : OPERAND;
begin
if not (not IS_DOUBLE[TYP1] and not IS_DOUBLE[TYP2]) then
ASSERTFAIL('TWO_SINGL001');
COERCE_DATUM (ARG1, TYP1);
if not RISFREE[S1RTB] and not((RTBUSER=ARG1) or (RTBUSER=ARG2))
then MOVE_AND_FREE_RTB;
REG_OPERAND (OPNDR, succ(S1RTB) );
COERCE_AND_MOVE_QUANTITY (OPNDR, ARG2, TYP2);
MOVE_QUANTITY (OPNDRTB, ARG1);
FREEDATUMREGS (ARG1);
FREEDATUMREGS (ARG2);
end (*TWO_SINGLE_ARGS*);
procedure CHECKFILADR (STE : STKINX);
(*Verify that STK[STE] is an address in (1,LCIOFILADR).*)
begin
if STK[STE].DTYPE <> TYPUA then
ERROR (WFILE_ADDRESS_NEEDED)
else if not DATUM_IS_FILADR(STE) then
ERROR (WSIO_DIDNT_SEE_FILEADDR);
end (*CHECKFILADR*);
procedure ALLOC_EXCESS (EXCWRDS : integer);
(*Allocate stack space for EXCWRDS excess parameter words.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITXOP (XADJSP_UP, OPNDRSP, OPND2)
end (*ALLOC_EXCESS*);
procedure EXCESS_ARG (NUM, TOT : integer;
ARG : STKINX; TYP : OPNDTYPE);
(*Store the argument into the NUMth excess parm location
in a block of TOT, coercing to type TYP if needed.*)
var OPND1 : OPERAND;
begin
REGDISP_OPERAND (OPND1, S1RSP, -(TOT-NUM+1) * WORDUNITS);
COERCE_AND_MOVE_QUANTITY (OPND1, ARG, TYP);
FREEDATUMREGS (ARG);
end (*EXCESS_ARGS*);
procedure DEALLOC_EXCESS (EXCWRDS : integer);
(*Deallocate EXCWRDS of stack space.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITTOP(XSUB_S, 0, OPNDRSP, OPND2);
end (*DEALLOC_EXCESS*);
procedure CHECK_REF_PARM (STE : STKINX);
(*The datum is the address of a reference parameter
(e.g. for a READ). If the reference parameter
is a local parm in a register, TRANSLATE_LVLDSP
has already changed the address to that of the
corresponding save location. We must finish
the job here by emitting moves in one or two
directions to fake the reference parameter
by a value result parameter. This procedure
merely notes whether such a simulation may be
necessary.*)
var FIRSTPARM : integer;
begin
with STK[STE], CURPROCSPEC do
begin
if not ( DTYPE = TYPUA) then ASSERTFAIL('CHECK_REF001');
FIRSTPARM := R_OFFSET;
if (NVPAS = 0) and (FPA.WHICH = MEM)
and (FPA.MEMADR.LVL = CURLVL)
and (FIRSTPARM <= FPA.MEMADR.DSPLMT)
and (FPA.MEMADR.DSPLMT < FIRSTPARM+REGPARMAREA) then
begin
FAKE_REF := true;
FAKE_PARMDISP := FPA.MEMADR.DSPLMT;
FAKE_PARMREG := PRM_TO_S1REG
[(FPA.MEMADR.DSPLMT - FIRSTPARM) div WORDUNITS];
end
else
FAKE_REF := false;
end (*with*)
end (*CHECK_REF_PARM*);
procedure RESULT_PARM (DTYPE : OPNDTYPE);
(*After completing the standard procedure, copy a
(possibly modified) local regparm back into the
register from the corresponding regparm save
location.
Note : no VALUE_PARM procedure is needed at
present because reference parms are only used
by standard procs if they wish to achieve result
parms.*)
var OPND1, OPND2 : OPERAND;
begin
if not ( FAKE_REF) then ASSERTFAIL('RESLT_PRM001');
REG_OPERAND (OPND1, FAKE_PARMREG);
REGDISP_OPERAND (OPND2, DISPLAY, FAKE_PARMDISP);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2)
end (*RESULT_PARM*);
begin (*CALLSTANDARD*)
CSP := NAME_TO_CSP(NAM1);
case CSP of
QATN, QEXP, QSIN, QCOS, QLOG, QSQT, QCLK :
begin
if CSP = QCLK then ONE_ARG (TOP, TYPUJ)
else ONE_ARG (TOP, TYPUR);
GENCALL (TOP);
REG_DATUM (TOP, STK[TOP].CODESTART, STK[TOP].DTYPE,S1RTB);
if CSP = QCLK then ALLOCRG (S1RTB) else ALLOCRP (S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[STK[TOP].DTYPE];
end (*QATN,...,QCLK*);
QXIT :
begin
ONE_ARG (TOP, TYPUJ);
GENCALL (TOP);
POPTOP;
end (*QXIT*);
QTRP :
begin
SAVE_PARMREGS;
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUJ, TYPUA);
GENCALL (TOP-1);
POPTOP; POPTOP;
RESTORE_PARMREGS;
end (*QTRP*);
QGET, QPUT, QRLN, QWLN : (*FILECH*)
begin
CHECKFILADR (TOP);
GENCALL (TOP);
end (*QGET,...,QWLN*); (*FILECH*)
(*FILECH...*)
QRES, QREW :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUA, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QRES, QREW*);
(*...FILECH*)
QRDB :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUB);
POPTOP;
end (*QRDB*);
QRDC :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUC);
POPTOP;
end (*QRDC*);
QRDI :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUJ);
POPTOP;
end (*QRDI*);
QRDR :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUR);
POPTOP;
end (*QRDR*);
QRDS :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUA, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QRDS*);
QWRB :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUB, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRB*);
QWRC :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUC, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRC*);
QWRI :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUJ, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRI*);
QWRR :
begin
POPTOP; (*Ignore fraction length for now. LCW*)
CHECKFILADR (TOP-2);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPUJ);
ONE_ARG (TOP-1, TYPUR);
GENCALL (TOP-2);
DEALLOC_EXCESS (1);
POPTOP; POPTOP;
end (*QWRR*);
QWRS :
begin
CHECKFILADR (TOP-3);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPUJ);
TWO_SINGLE_ARGS (TOP-2, TOP-1, TYPUA, TYPUJ);
GENCALL (TOP-3);
DEALLOC_EXCESS (1);
POPTOP; POPTOP; POPTOP;
end (*QWRS*);
QELN, QEOF :
begin
CHECKFILADR (TOP);
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
GENCALL (TOP);
(*Insert the boolean answer under the FILADR.*)
PUSHTOP;
if not (RISFREE[S1RTB] or (RTBUSER<>TOP-1)) then
ASSERTFAIL('QELN,QEOF001');
STK[TOP] := STK[TOP-1];
(*This works since datum does not include RTB.*)
REG_DATUM (TOP-1, STK[TOP-1].CODESTART,
TYPUB, S1RTB);
STK[TOP-1].BREPRES := BINTVAL;
ALLOCRG (S1RTB);
RTBUSER := TOP-1;
RTBDOUB := false;
end (*QELN, QEOF*);
QSIO :
begin
REGDISP_OPERAND (OPND1,
LVL_TO_S1REG[1],
LCIOFILADR + FILE_OFFSET);
with STK[TOP] do
begin
if DTYPE <> TYPUA then
ERROR (WSIO_WITH_NONADDRESS);
MOVE_QUANTITY (OPND1, TOP);
FREEDATUMREGS (TOP);
RESCODESTART := CODESTART;
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUA;
NVPAS := 1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := 1;
VPA1.VPA.MEMADR.DSPLMT :=
LCIOFILADR + FILE_OFFSET;
end (*with STK[TOP] do*);
end (*QSIO*);
QEIO :
begin
CHECKFILADR (TOP);
POPTOP;
end (*QEIO*);
QNEW :
begin
if not IS_INTEGER[STK[TOP].DTYPE] or
(STK[TOP-1].DTYPE <> TYPUA) then
ERROR (WNEW_MUST_HAVE_ADDR_AND_INT);
COERCE_DATUM (TOP, TYPUJ);
GET_OPERAND (OPND2, TOP);
(*Check alignment.*)
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT
mod WORDUNITS <> 0 then
ERROR (WALIGNMENT_ERROR);
end
else if DEBUG then
begin (*Check at run time.*)
IMM_OPERAND (OPND1, WORDUNITS-1);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_S, 0, OPND1, OPND2, nil);
IMM_OPERAND (OPNDI1, 1);
IMM_OPERAND (OPNDI2, -1);
(*Check 0<=-1<=1 : fake TRAP SELF*)
EMITXOP (XBTRP_0_S, OPNDI1, OPNDI2); (*BNDTRPKLU*)
(* EMITJOP(XHALT,0,UNUSED_OP,ZERO_OP,NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIPLOC, NEWINSTREC);
end (*Check at run time.*);
REG_OPERAND (OPNDR, pred(S1RNP)); (*SP-NP pair*)
EMITXOP (XADJSP_DN, OPNDR, OPND2);
GET_ADDRESS (OPND1, TOP-1);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP); POPTOP;
FREEDATUMREGS (TOP); POPTOP;
end (*QNEW*);
QSAV :
begin
if STK[TOP].DTYPE <> TYPUA then
ERROR (WSAV_NEEDS_ADDR);
GET_ADDRESS (OPND1, TOP);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP);
POPTOP;
end (*QSAV*);
QRST :
begin
if STK[TOP].DTYPE <> TYPUA then
ERROR (WRST_NEEDS_ADDR);
if DEBUG then
begin
ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
GET_OPERAND (OPND2, TOP); (*BNDTRPKLU*)
EMITXOP (XBTRP_B_S, OPND1, OPND2); (*BNDTRPKLU*)
(* GET_OPERAND (OPND2, TOP); (*BNDTRPKLU*)
(* ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
(* SKIP1LOC := NEWINSTREC; (*BNDTRPKLU*)
(* EMITSOP (XSKP_LSS_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
(* ADDR_OPERAND (OPND1, S1RNPMEMADR+WORDUNITS); (*BNDTRPKLU*)
(* SKIP2LOC := NEWINSTREC; (*BNDTRPKLU*)
(* EMITSOP (XSKP_LEQ_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
(* FIXSOP (SKIP1LOC, NEWINSTREC); (*BNDTRPKLU*)
(* EMITJOP (XHALT, 0, UNUSED_OP, ZERO_OP, (*BNDTRPKLU*)
(* NEWINSTREC); (*BNDTRPKLU*)
(* FIXSOP (SKIP2LOC, NEWINSTREC); (*BNDTRPKLU*)
end (*DEBUG*);
REG_OPERAND (OPNDR, S1RNP);
MOVE_QUANTITY (OPNDR, TOP);
FREEDATUMREGS (TOP);
POPTOP;
end (*QRST*);
end (*case CSP of*);
if (CSP in [QGET,QPUT,QRDB,QRDC,QRDI,QRDR,QRDS,
QRES,QREW,QRLN,QWLN,QWRB,QWRC,QWRI,QWRR,QWRS])
and (TOP <> BOT) then
ERROR (WSTACK_NOT_SINGLE)
else if (CSP in [QTRP,QXIT,QNEW,QSAV,QRST])
and (TOP <> BOT-1) then
ERROR (WSTACK_NON_EMPTY);
end (*CALLSTANDARD*);
(*** ASSEMBLE_NEXT_INSTRUCTION_CLASS: ASMNXTINST ***)
(**)
procedure ASMNXTINST;
var
S1OP, MOVEOP : S1OPCODE;
OPND, OPND1, OPND2, OPNDR, OPNDR1, OPNDR2 : OPERAND;
RESTYPE : OPNDTYPE;
RESCODESTART : A_CODEREC;
RESDBL : boolean;
LOWBOUND, HIGHBOUND : integer; (* peg 07jul79 *)
CORRECT, NO_ERROR, BOOL_IN_STK : boolean; (* peg *)
COMBINABLE, CALCULABLE : boolean;
TOOMUCH1, TOOMUCH2 : boolean;
STE, PARM, UNSIMPLE, SIMPLER, GROUP1, GROUP2 : STKINX;
PTR, NEXT : A_CODEREC;
INSTLOC, SKIPLOC, JUMPLOC, FALLTHRUJUMP : A_CODEREC;
SKIP1LOC, SKIP2LOC : A_CODEREC; (*BNDTRPKLU*)
TMPJUMPLIST : JUMPLIST;
DEST, DEST1, DEST2, OP1RG, OP2RG, OPRRG : S1REGISTER;
DESTREGS : SETOFS1REGS; (*PEG*)
OP1GBL : S1GBL;
LPTR : A_LBLHASHENT;
ONE_IF_OR : BIT;
MAXFINALIND : INDIRECTION;
PR_BIT : BIT;
SP_TWIDDLE : integer;
SKIPSMALL, SKIPNOTBIG, JUMPDEFAULT, JUMPINDEXED : A_CODEREC;
EXCESS : integer;
CONSTPART : integer;
SHIFTDIST : integer;
I : integer;
STARTBIT : S1BITNUM;
INDEX : SETPART_INDEX; (*setch*)
PREG : S1REGISTER; (* peg 01aug79 *)
LASTREGPARM : STKINX; (* peg 09aug79 *)
LASTPREG, DESTLASTPREG : -1..MAXPAREGM1;
PWORD : NONNEGINT;
PREGS : NUMBER_OF_PAREGS;
DSPL : integer;
OFFSET : integer; (*peg 03aug79*)
LABNUM, LABNUM1, LABNUM2 : LBL_INDEX;
RTBSAVED : boolean;
RTBDATUM : STKINX;
RTBDSPL : integer;
IPTR : A_CODEREC;
S1PC : integer;
XFER_CNT : integer;
(*** ANI_CLASS: ARITH_1_OPS UABS UNEG UADD UINC UDEC ***)
(**)
procedure ARITH_1_OPS;
begin
case OPC of
UABS, UNEG : (* als/peg 28jun79 *)
with STK[TOP] do
begin
if TYP <> DTYPE then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not IS_SIGNED_NUM[DTYPE] then ERROR(WABS_OR_NEG_OF_NONSIGNED);
if IS_CONSTANT(TOP) then
begin
if IS_INTEGER[DTYPE] then
if OPC = UABS then
FPA.MEMADR.DSPLMT := ABS(FPA.MEMADR.DSPLMT)
else (*OPC = UNEG*)
FPA.MEMADR.DSPLMT := -FPA.MEMADR.DSPLMT
else (*IS_REAL*)
if OPC = UABS then
RCNST := ABS(RCNST)
else (*OPC = UNEG*)
RCNST := -RCNST
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
FREEDATUMREGS(TOP);
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
REG_OPERAND(OPND1,NXTRG);
if OPC = UABS then S1OP := ABS_X[DTYPE]
else S1OP := NEG_X[DTYPE];
EMITXOP(S1OP,OPND1,OPND2);
REG_DATUM(TOP,CODESTART,DTYPE,NXTRG)
end (*not constant*)
end (*UABS, UNEG*);
UADD : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
if ((TYP = TYPUJ) or (TYP = TYPUL)) then
ADD_TOP_TWO_DATUMS
else
begin (*TYPUI TYPUK*)
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XADD_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
with STK[TOP] do
REG_DATUM (TOP, CODESTART, TYP, DEST);
end (*TYPUI TYPUK*);
end (*IS_INTEGER*) else
if IS_REAL[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('UADD 001');
STK[TOP-1].RCNST := STK[TOP-1].RCNST + STK[TOP].RCNST;
POPTOP;
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (* UADD *);
UINC, UDEC : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not ((IS_INTEGER[TYP]) or (TYP in [TYPUA,TYPUB,TYPUC])) then
ERROR(WINVAL_U_TYPECODE);
if TYP = TYPUA then
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
if OPC = UDEC then I1 := -I1;
INCREMENT_DATUM (TOP, I1);
end (*UINC,UDEC*);
end (*case OPC of*)
end (*ARITH_1_OPS*);
(*** ANI_CLASS: ARITH_2_OPS USUB ***)
(**)
procedure ARITH_2_OPS;
begin
case OPC of
USUB : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := TYP;
if ((TYP = TYPUI) or (TYP = TYPUK)) then
begin
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XSUB_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
end (*TYPUI, TYPUK*)
else
begin (*TYPUJ, TYPUL*)
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
COMBINABLE := false;
CALCULABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA) then
COMBINABLE := true
else if IS_CONSTANT(TOP) and (STK[TOP-1].FINALIND=IND0) then
COMBINABLE := true
else
begin (*not combinable*)
CONSTPART := 0;
with STK[TOP-1] do
if FINALIND = IND0 then
begin
CONSTPART := FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
with STK[TOP] do
if FINALIND = IND0 then
begin
CONSTPART := CONSTPART - FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA) then
begin (*replace hard zero by const part*)
STK[TOP-1].FPA.MEMADR.DSPLMT := CONSTPART;
CONSTPART := 0;
end
else if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA) then
begin (*replace hard zero by const part*)
STK[TOP].FPA.MEMADR.DSPLMT := -CONSTPART;
CONSTPART := 0;
end;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
CALCULABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
CONSTPART := -CONSTPART;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else (*select one at random*)
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end;
if CONSTPART <> 0 then
if STK[UNSIMPLE].FINALIND = IND0 then
begin
if not (STK[UNSIMPLE].FPA.MEMADR.DSPLMT=0) then
ASSERTFAIL('USUB 001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT:=CONSTPART
end
else
begin
if not((STK[SIMPLER].FINALIND=IND0) and
(STK[SIMPLER].FPA.MEMADR.DSPLMT=0)) then
ASSERTFAIL('USUB 002');
STK[SIMPLER].FPA.MEMADR.DSPLMT:=CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
begin
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT - STK[TOP].FPA.MEMADR.DSPLMT;
POPTOP;
STK[TOP].CODESTART := RESCODESTART;
end (*COMBINABLE*)
else
begin (*CALCULABLE*)
ADD_SUB_SINGLE (DEST, XSUB_S, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*);
end (*TYPUJ, YYPUL*);
end (*IS_INTEGER*)
else if IS_REAL[TYP] then
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
STK[TOP-1].RCNST := STK[TOP-1].RCNST - STK[TOP].RCNST;
POPTOP
end
else (*not both constants*)
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
else ERROR(WARITH_ON_WRONG_DT);
end (* USUB *);
end (*case OPC of*)
end (*ARITH_2_OPS*);
(*** ANI_CLASS: ARITH_3_OPS UMPY USQR ***)
(**)
procedure ARITH_3_OPS;
begin
case OPC of (*UMPY, USQR*)
UMPY : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := TYP;
if ((TYP = TYPUI) or (TYP = TYPUK)) then
begin
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XMULT_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
end (*TYPUI TYPUK*)
else
begin (*TYPUJ TYPUL*)
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
COMBINABLE := false;
CALCULABLE := false;
repeat
if IS_CONSTANT(TOP) then
begin
if IS_CONSTANT(TOP-1) then
COMBINABLE := true
else
begin
SHIFTDIST := POWER2(STK[TOP].FPA.MEMADR.DSPLMT);
with STK[TOP-1] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or ((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) )) then
COMBINABLE := true;
end;
end (*constant top*)
else if IS_CONSTANT(TOP-1) then
begin
SHIFTDIST := POWER2(STK[TOP-1].FPA.MEMADR.DSPLMT);
with STK[TOP] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or ((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) )) then
COMBINABLE := true;
end (*constant second from top*);
if not COMBINABLE then
begin
if IS_CONSTANT(TOP-1) and IS_CONST_PLUS_OPND(TOP) then
begin (*const*uncomplicated*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, STK[TOP-1].FPA.MEMADR.DSPLMT);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('UMPY 001');
CALCULABLE := true;
end (*const*uncomplicated*)
else if IS_CONSTANT(TOP) and IS_CONST_PLUS_OPND(TOP-1) then
begin (*uncomplicated*const*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
if not (not TOOMUCH1) then ASSERTFAIL('UMPY 002');
IMM_OPERAND (OPND2, STK[TOP].FPA.MEMADR.DSPLMT);
CALCULABLE := true;
end (*const*uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
begin
CONSTPART := 0;
CALCULABLE := true;
end
else
begin (*must simplify*)
if not TOOMUCH1 then
SIMPLIFY (TOP)
else if not TOOMUCH2 then
SIMPLIFY (TOP-1)
else (*select one at random*)
SIMPLIFY (TOP);
end (*must simplify*);
end (*general case*);
end (*if not COMBINABLE*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT * STK[TOP].FPA.MEMADR.DSPLMT;
if (STK[TOP-1].NVPAS=0) and (STK[TOP].NVPAS<>0) then
begin
STK[TOP-1].NVPAS := STK[TOP].NVPAS;
STK[TOP-1].VPA1 := STK[TOP].VPA1;
(*Multiplicands not combinable if 2 VPAs exist*)
end;
with STK[TOP-1] do
begin
if not (NVPAS <= 1) then ASSERTFAIL('UMPY 003');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART;
end;
POPTOP;
end (*COMBINABLE*);
end (*TYPUJ TYPUL*)
end (*UMPY I*) else
if IS_REAL[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('UMPY 004');
STK[TOP-1].RCNST := STK[TOP-1].RCNST * STK[TOP].RCNST;
POPTOP;
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*);
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (*UMPY*);
USQR : (* als/peg 28jun79 *)
with STK[TOP] do
begin
if DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not (IS_REAL[TYP] or IS_INTEGER[TYP]) then
ERROR(WSQUARE_OF_INVALID_TYPE)
else
begin
if IS_CONSTANT(TOP) then
begin
if TYP in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
if IS_INTEGER[TYP] then
FPA.MEMADR.DSPLMT := sqr(FPA.MEMADR.DSPLMT)
else (*IS_REAL(RESTYPE)*)
RCNST := sqr(RCNST)
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
if ((TYP = TYPUJ) or (TYP = TYPUL)) then S1OP := XMULT_S
else if ((TYP = TYPUI) or (TYP = TYPUK)) then S1OP := XMULT_D
else if TYP = TYPUR then S1OP := XFMULT_S
else if TYP = TYPUQ then S1OP := XFMULT_D
else ASSERTFAIL('UMPY 005');
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND2, OPND2,
IS_DOUBLE[TYP],IS_DOUBLE[TYP], IS_DOUBLE[TYP], TOP);
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,CODESTART,TYP,DEST);
end (*not constant*);
end;
end (*with STK[TOP] do*);
end (*case OPC of*)
end (*ARITH_3_OPS*);
(*** ANI_CLASS: ARITH_4_OPS UDIV UDMD UMOD ***)
(**)
procedure ARITH_4_OPS;
begin
case OPC of (*UDIV, UDMD, UMOD*)
UDIV, UDMD, UMOD : (* als/peg 03jul79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if RESDBL then ERROR(WNOT_IMPLEMENTED);
if STK[TOP].FPA.MEMADR.DSPLMT = 0 then
ERROR(WINTEGER_CONSTANT_DIV_MOD_BY_ZERO)
else if OPC = UDMD then
begin
STK[TMPD1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT div STK[TOP].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT mod STK[TOP].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := STK[TMPD1].FPA.MEMADR.DSPLMT;
end
else
begin
if OPC = UDIV then STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT div STK[TOP].FPA.MEMADR.DSPLMT
else STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT mod STK[TOP].FPA.MEMADR.DSPLMT;
POPTOP
end
end
else (*not both constants*)
begin
if OPC = UDMD then (* peg 03jul79...*)
begin
if RESDBL then
begin
ERROR(WNOT_IMPLEMENTED);
% S1OP := XDIV_D;
FINDRGBLOCK(4);
DEST1 := NXTRG;
DEST2 := NXTRG + 2;
FREERG_S(DEST1);
ALLOCRP(DEST1);
ALLOCRP(DEST2); \(* als/peg 01aug79 *)
end
else
begin
S1OP := XDIV_S;
FINDRP;
DEST1 := NXTRG;
DEST2 := NXTRG + 1;
FREERG_S(DEST1);
ALLOCRG(DEST1);
ALLOCRG(DEST2);
end;
REG_OPERAND(OPNDR1, DEST1);
REG_OPERAND(OPNDR2, DEST2);
GET_OPERAND(OPND1, TOP-1);
GET_OPERAND(OPND2, TOP);
EMITXOP(MOV_X_X[RESTYPE], OPNDR1, OPND1);
EMITTOP(S1OP, 0, OPNDR1, OPND2);
FREEREGSBUTTHESE(TOP-1, [DEST1, DEST2]);
FREEREGSBUTTHESE(TOP, [DEST1, DEST2]);
REG_DATUM(TOP-1, RESCODESTART, RESTYPE, DEST1);
REG_DATUM(TOP, RESCODESTART, RESTYPE, DEST2);
end (*...peg 03jul79 *)
else
begin
if OPC = UDIV then
if RESDBL then S1OP := XQUO_D
else S1OP := XQUO_S
else (*OPC = UREM*)
if RESDBL then S1OP := XREM_D
else S1OP := XREM_S;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST,S1OP,OPND1,OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP, RESCODESTART, RESTYPE, DEST)
end
end (*not both constants*)
end (*IS_INTEGER, UMOD, UDMD*) else
if ((IS_REAL[TYP]) and (OPC = UDIV)) then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('ARITH_4 001');
begin
if STK[TOP].RCNST = 0 then
ERROR(WREAL_CONSTANT_DIVISION_BY_ZERO)
else STK[TOP-1].RCNST := STK[TOP-1].RCNST / STK[TOP].RCNST
end;
POPTOP
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (*UDIV,UDMD,UMOD*);
end (*case OPC of*)
end (*ARITH_4_OPS*);
(*** ANI_CLASS: COMPARE_SETS REL_OPS UEQU UGEQ UGRT ULEQ ULES UNEQ UIEQU UIGEQ UIGRT UILEQ UILES UINEQ ***)
(**)
procedure COMPARE_SETS; (*peg 03jul79...*)
(*Do the comparisons UEQU, UNEQ, UGEQ, and ULEQ for TYPUS operands.
GEQ is 'optimized' to an LEQ with the operands reversed
(GEQ and LEQ are the set inclusion operators; LEQ is thus
implemented as an AND RSET,SET1,SET2 followed by
EQU BOOL,RSET,SET2).*)
var BOOL : boolean;
begin
if (STK[TOP-1].DTYPE <> TYPUS) or (STK[TOP].DTYPE <> TYPUS) then
ERROR (WCOMPARE_ILLEGAL)
else if not (OPC in [UEQU, UNEQ, UGEQ, ULEQ]) then
ERROR (WWRONG_COMPARE)
else
begin (*setch...*)
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP)
and ((OPC = UEQU) or (OPC = UNEQ)) then
begin
if OPC = UEQU then
BOOL := STK[TOP-1].SCNST = STK[TOP].SCNST
else if OPC = UNEQ then
BOOL := STK[TOP-1].SCNST <> STK[TOP].SCNST
else if not (false) then ASSERTFAIL('COMPARE_S001');
POPTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := ord(BOOL);
end (*with STK[TOP] do*);
end (*if constants*)
else
begin (*not constant*)
LOADSTACKEXCEPT(TOP-1, TOP);
RESCODESTART := STK[TOP-1].CODESTART;
TMPJUMPLIST := EMPTYJUMPLIST;
if OPC = UGEQ then
begin
XCHANGE_STKENTS(TOP, TOP-1);
OPC := ULEQ;
end;
if OPC = ULEQ then
begin
FINDRGBLOCK(NUMOFSETPARTS*2);
DEST := NXTRG;
for I := 0 to (1 + SETPART_MAX*2) do
DESTREGS := DESTREGS + [DEST + I];
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRP(S1RTB);
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
EMITTOP(XAND_D, 3, OPND1, OPND2); (*Result ==> RTB*)
REG_OPERAND(OPNDR, DEST + INDEX*2);
EMITXOP(XMOVMS_2, OPNDR, OPNDRTB);
end;
WHICHPART := 0;
FREERG_S(S1RTB);
FREEREGSBUTTHESE(TOP-1,DESTREGS);
REG_DATUM(TOP-1, STK[TOP-1].CODESTART, TYPUS, DEST);
end (*if OPC = ULEQ*);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_EQL_D, 0, OPND1, OPND2, nil);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
if INDEX < SETPART_MAX then
ADD_JUMP_TO_JUMPLIST(TMPJUMPLIST, JUMPLOC);
FIXSOP (SKIPLOC, NEWINSTREC);
end;
WHICHPART := 0;
FREEDATUMREGS(TOP-1);
FREEDATUMREGS(TOP);
POPTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*to make it not look
like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
if OPC = UNEQ then
begin
BFALSELIST := EMPTYJUMPLIST;
BTRUELIST := TMPJUMPLIST;
BJUMPON := true;
end
else (*OPC in [UEQU, ULEQ, UGEQ]*)
begin
BFALSELIST := TMPJUMPLIST;
BTRUELIST := EMPTYJUMPLIST;
BJUMPON := false;
end;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*not constant*)
end (*...setch*)
end (*COMPARE_SETS*); (*...peg 15MAY79*)
procedure REL_OPS;
begin
case OPC of
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, (* als/peg 03jul79 *)
UIEQU, UINEQ, UIGEQ, UIGRT, UILEQ, UILES :
begin
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if (OPC = UIEQU) or (OPC = UINEQ) or (OPC = UIGEQ)
or (OPC = UIGRT) or (OPC = UILEQ) or (OPC = UILES) then
begin
for STE := TOP-1 to TOP do
with STK[STE] do
begin
INC_INDIRECTION(STE, IND1);
DTYPE := TYP;
DLENGTH := I1;
end (*with STK[STE] do*);
case OPC of
UIEQU : OPC := UEQU;
UINEQ : OPC := UNEQ;
UIGEQ : OPC := UGEQ;
UIGRT : OPC := UGRT;
UILEQ : OPC := ULEQ;
UILES : OPC := ULES;
end (*case*)
end (*UIEQU...UILES*);
if TYP = TYPUS then COMPARE_SETS
else if TYP <> TYPUM then
begin
if TYP in [TYPUJ, TYPUL] then
begin
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
end;
RESTYPE := COMPARE_COERCE_TYPE
[STK[TOP-1].DTYPE, STK[TOP].DTYPE];
if RESTYPE = ILLCOMP then
ERROR (WCOMPARE_ILLEGAL)
else if RESTYPE <> TYP then
ERROR (WWRONG_COMPARE);
RESCODESTART := STK[TOP-1].CODESTART;
COERCE_DATUM (TOP-1, RESTYPE);
COERCE_DATUM (TOP, RESTYPE);
if (RESTYPE in [TYPUA, TYPUI, TYPUJ, TYPUK, TYPUL]) and
(STK[TOP-1].FINALIND=IND0) and (STK[TOP].FINALIND=IND0) then
begin (*Bring constant parts to one side.*)
if not ((STK[TOP-1].FPA.WHICH = MEM) and
(STK[TOP].FPA.WHICH = MEM)) then
ASSERTFAIL('REL_OPS 001');
STK[TOP].FPA.MEMADR.DSPLMT :=
STK[TOP].FPA.MEMADR.DSPLMT - STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end (*Bring constant parts to one side.*);
if RESTYPE = TYPUB then
begin
if STK[TOP-1].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP-1);
if STK[TOP].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP);
(*Note : <=,>=,<,> could be optimized as and, or are.*)
end;
S1OP := COMPARE_OP[S1SIZE[RESTYPE], OPC];
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
LOADSTACKEXCEPT (TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
end (*TYP<>TYPUM*)
else
begin (*TYP = TYPUM*)
if not(STK[TOP-1].DTYPE in [TYPUA, TYPUM]) or
not(STK[TOP].DTYPE in [TYPUA, TYPUM]) then
ERROR (WCOMPM_NEEDS_ADDR);
(* make sure the zero and CPLPL global are free (to prevent errors) *)
ALLOCGBL (S1GBLZ);
OP1GBL := S1GCPLPL;
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(* initialize the CPLPL block-descriptor *)
OP1GBL := S1GCPLPL;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP-1);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
(* emit the BLKCMP and subsequent flag test *)
ADDR_OPERAND (OPND2, S1GCPLPL*WORDUNITS); (*LCW*)
FREEDATUMREGS(TOP); (*EJG 16JAN79*)
FREEDATUMREGS(TOP-1); (*EJG 16JAN79*)
FINDRG;
OP1RG := NXTRG;
REG_OPERAND (OPND1, OP1RG);
EMITXOP (BLKCMP_X_Q[OPC], OPND1, OPND2);
DEST := OP1RG;
LOADSTACKEXCEPT (TOP-1, TOP);
POPTOP;
REG_OPERAND (OPND1, DEST);
IMM_OPERAND (OPND2, S1TRUEFLAG);
S1OP := XSKP_EQL_S;
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
FREERG_S (DEST);
(* free the global zero and CPLPL global *)
FREEGBL_S (S1GBLZ);
OP1GBL := S1GCPLPL;
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
end (*TYPUM*);
SKIPLOC := NEWINSTREC;
EMITSOP (S1OP, 0, OPND1, OPND2, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := false;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*UEQU,...,UILES*);
end (*case OPC of*)
end (*REL_OPS*);
(*** ANI_CLASS: BOOL_OPS UAND UIOR UXOR UNOT UODD ***)
(**)
procedure BOOL_OPS;
begin
case OPC of
UAND, UIOR, UXOR : (* als/peg 03jul79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if TYP <> TYPUB then ERROR (WANDOR_NEEDS_BOOLEAN);
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
case OPC of
UAND :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
and (STK[TOP].FPA.MEMADR.DSPLMT = 1));
UIOR :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
or (STK[TOP].FPA.MEMADR.DSPLMT = 1));
UXOR :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord( ((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
or (STK[TOP].FPA.MEMADR.DSPLMT = 1))
and not((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
and (STK[TOP].FPA.MEMADR.DSPLMT = 1)) );
end (*case*);
POPTOP;
end (*constant bintvals*)
else
begin (*non-constant bintvals*)
if STK[TOP-1].BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP-1);
if STK[TOP].BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP);
(* Eliminate codeforks.*)
RESCODESTART := STK[TOP-1].CODESTART;
if OPC = UAND then S1OP := XAND_Q
else if OPC = UIOR then S1OP := XOR_Q
else S1OP := XXOR_Q;
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND1, OPND2,
false, false, false, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, TYPUB, DEST);
STK[TOP].BREPRES := BINTVAL;
end (*non-constant bintvals*);
end (*UAND, UIOR, UXOR*);
UNOT : (* als/peg 03jul79 *)
with STK[TOP] do
begin
if DTYPE <> TYPUB then
ERROR (WNOT_NEEDS_BOOLEAN);
RESCODESTART := CODESTART;
if BREPRES = BJUMP then
begin
TMPJUMPLIST := BTRUELIST;
BTRUELIST := BFALSELIST;
BFALSELIST := TMPJUMPLIST;
BJUMPON := not BJUMPON;
end (*BJUMP*)
else
begin (*BINTVAL*)
if IS_CONSTANT(TOP) then
FPA.MEMADR.DSPLMT := 1 - FPA.MEMADR.DSPLMT
else
begin (*non-constant bintval*)
GET_OPERAND (OPND1, TOP);
IMM_OPERAND (OPND2, 1);
ALLOC_AND_EMIT_TOP (DEST, XXOR_Q, OPND1, OPND2,
false, false, false, TOP);
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, CODESTART, TYPUB, DEST);
BREPRES := BINTVAL;
end (*non-constant bintval*);
end (*BINTVAL*);
end (*UNOT*);
UODD : (* als/peg 03jul79 *)
with STK[TOP] do
begin
if not IS_INTEGER[DTYPE] then
ERROR(WODD_REQUIRES_AN_INTEGER);
if IS_CONSTANT(TOP) then
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT := ord(odd(FPA.MEMADR.DSPLMT))
end
else
begin (*not constant*)
RESCODESTART := CODESTART;
GET_OPERAND(OPND1,TOP);
IMM_OPERAND(OPND2,1);
LOADSTACKEXCEPT(TOP, TOP);
if not RISFREE[S1RTB] and (RTBUSER <> TOP) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS(TOP);
SKIPLOC := NEWINSTREC;
EMITSOP(SKP_NON_X[DTYPE],0,OPND1,OPND2,nil);
EMITJOP(XJMPA,0,UNUSED_OP,ZERO_OP,nil);
FIXSOP(SKIPLOC,NEWINSTREC);
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*To make it not look like a constant.
Hopefully not needed.*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*not constant*)
end (*UODD*);
end (*case OPC of*)
end (*BOOL_OPS*);
(*** ANI_CLASS: SET_OPS UDIF UINT UUNI UINN USGS UADJ UMUS ***)
(**)
procedure SET_OPS;
begin
case OPC of
UDIF, UINT, UUNI : (* als/peg 05jul79 *)
begin
if (STK[TOP-1].DTYPE <> TYPUS) or (STK[TOP].DTYPE <> TYPUS) then
ERROR(WSET_OPERATION_ON_NONSET_TYPES)
else
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if OPC = UDIF then
(*setch*) SET_DIF(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if OPC = UINT then
(*setch*) SET_INT(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if OPC = UUNI then
(*setch*) SET_UNI(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if not (false) then ASSERTFAIL('UDIF,UINT001');
POPTOP
end
else (*not both constants*)
begin
if OPC = UDIF then S1OP := XAND_TC_D
else if OPC = UINT then S1OP := XAND_D
else if OPC = UUNI then S1OP := XOR_D
else if not (false) then ASSERTFAIL('UDIF,UINT002');
FINDRGBLOCK(NUMOFSETPARTS*2); (*setch...*)
DEST := NXTRG;
for I := 0 to (1 + SETPART_MAX*2) do
DESTREGS := DESTREGS + [DEST + I];
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRP(S1RTB);
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
EMITTOP(S1OP, 3, OPND1, OPND2); (*Result ==> RTB*)
REG_OPERAND(OPNDR, DEST + INDEX*2);
EMITXOP(XMOVMS_2, OPNDR, OPNDRTB);
end;
WHICHPART := 0;
FREERG_S(S1RTB);
FREEREGSBUTTHESE(TOP-1,DESTREGS);
FREEREGSBUTTHESE(TOP,DESTREGS);
REG_DATUM(TOP-1, STK[TOP].CODESTART, TYPUS, DEST);
POPTOP; (*...setch*)
end (*not both constants*)
end (*UDIF, UINT, UUNI*);
USGS, UINN : (* als/peg 05jul79 *)
begin
if OPC = USGS then STE := TOP else STE := TOP-1;
with STK[STE] do
begin
if not IS_INTEGER[DTYPE] and not (DTYPE in [TYPUB,TYPUC]) then
ERROR(WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN);
if DTYPE in [TYPUB,TYPUC] then
begin
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL(STE);
DTYPE := TYPUJ
end;
if IS_CONSTANT(STE) then
begin
if DTYPE in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
if (FPA.MEMADR.DSPLMT < 0) or (FPA.MEMADR.DSPLMT > SET_MAX) then
ERROR(WCONST_OUT_OF_RANGE_FOR_SET);
DTYPE := TYPUS;
SCNST := NULL_SET; (*setch*)
BUILD_SET(SCNST, FPA.MEMADR.DSPLMT); (*setch*)
FPA := ZEROFPA;
end
else
begin (*not constant*)
if DTYPE in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
FINDRG; OPRRG := NXTRG; (*setch...*)
REG_OPERAND(OPNDR,OPRRG);
GET_OPERAND(OPND2,STE);
EMITXOP(XMOV_S_S, OPNDR, OPND2);
FREEREGSBUTTHESE(STE, [OPRRG]);
FINDRGBLOCK(NUMOFSETPARTS*2);
DEST := NXTRG;
for INDEX := SETPART_MAX downto 0 do
begin
IMM_OPERAND(OPND2,1);
REG_OPERAND(OPND1, DEST + INDEX*2);
EMITXOP(XMOV_D_S,OPND1,OPND2);
EMITTOP(XSHF_LF_D, 0, OPND1, OPNDR);
if INDEX > 0 then
begin
IMM_OPERAND(OPND2, SET_SIZE div NUMOFSETPARTS);
EMITTOP(XSUB_S, 0, OPNDR, OPND2);
end;
end;
REG_DATUM(STE, CODESTART, TYPUS, DEST);
FREERG_S(OPRRG); (*...setch*)
end (*not constant*)
end (*with STK[STE] do*);
if OPC = UINN then
begin
if STK[TOP].DTYPE <> TYPUS then
ERROR(WINN_REQUIRES_SET_ON_TOP_OF_STACK);
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
with STK[TOP-1] do
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
SET_INT(SCNST, SCNST, STK[TOP].SCNST); (*setch...*)
FPA.MEMADR.DSPLMT := ord(SCNST <> NULL_SET);
SCNST := NULL_SET; (*...setch*)
end;
POPTOP;
end
else
begin (*not constants*)
LOADSTACKEXCEPT(TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
RESCODESTART := STK[TOP-1].CODESTART;
TMPJUMPLIST := EMPTYJUMPLIST; (*setch...*)
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_D, 0, OPND1, OPND2, nil);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
if INDEX < SETPART_MAX then
ADD_JUMP_TO_JUMPLIST(TMPJUMPLIST, JUMPLOC);
FIXSOP (SKIPLOC, NEWINSTREC);
end;
WHICHPART := 0;
FREEDATUMREGS(TOP-1);
FREEDATUMREGS(TOP); (*...setch*)
POPTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*to make it not look
like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := TMPJUMPLIST; (*setch*)
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*not constants*);
end (*if OPC = UINN*);
end (*USGS, UINN*);
UADJ : (**** Write UADJ, UMUS.*)
begin
ERROR (WNOT_IMPLEMENTED);
end (*UADJ*);
UMUS :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UMUS*);
end (*case OPC of*)
end (*SET_OPS*);
(*** ANI_CLASS: LOAD1_STORE_OPS ULCA ULDA ULDC ULOD ULDP UILOD UPLOD ***)
(**)
procedure LOAD1_STORE_OPS;
begin
case OPC of
ULCA :
begin
if not (TYP in [TYPUB, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL,
TYPUM, TYPUQ, TYPUR, TYPUS]) then ERROR(WWRONG_INSTR_DATATYPE);
if TYP <> TYPUM then ERROR(WNOT_IMPLEMENTED);
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUM;
DLENGTH := I1;
MTYPE := M_SPACE;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := NXTSTRDISP;
STARTBIT := NXTSTRDISP mod WORDCHARS * CHARBITS;
for I := 1 to SLGTH do
begin
if STARTBIT = 0 then
EMIT_ZEROS1WORD (STRINGAREA, STRINGAR_CPTR);
PUTFIELD (STRINGAR_CPTR↑.CODEWORD, STARTBIT,
CHARBITS, ord(SVAL[I])-CHARDIF ); (*CHARDIF*)
STARTBIT := (STARTBIT + CHARBITS) mod WORDBITS;
end;
NXTSTRDISP := NXTSTRDISP + SLGTH;
end (*with STK[TOP] do*);
end (*PLCA*);
ULDA : (* peg 03jul79 *)
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUA;
DLENGTH := I3;
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end (*with STK[TOP] do*);
end (*ULDA*);
ULDC : (* peg 03jul79 *)
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I1;
MTYPE := DEFAULTMTYPE;
case TYP of
TYPUB :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I2;
BREPRES := BINTVAL;
end;
TYPUC :
begin
if SLGTH <> 1 then ASSERTFAIL('ULDC 001');
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := ord(SVAL[1]) - CHARDIF;
end;
TYPUJ :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I2;
end;
TYPUR : RCNST := R1;
TYPUN : (*null case*);
TYPUS : SCNST := P1;
TYPUA, TYPUP :
ERROR (WINVAL_TYP_ON_LDC);
TYPUI, TYPUM, TYPUQ :
ERROR (WNOT_IMPLEMENTED);
end (*case TYP of*);
end (*with STK[TOP] do*);
end (*LDC*);
ULOD : (* peg 03jul79 *)
begin
if (I2 div QWBITS) mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := BLOCKTABLE[I1];
VPA1.VPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (VPA1.VPA, MTYP);
if TYP = TYPUB then BREPRES := BINTVAL;
end (*with STK[TOP] do*);
end (*ULOD*);
ULDP :
begin
ERROR(WNOT_IMPLEMENTED);
end (*ULDP*);
UILOD : (* als/peg 03jul79 *)
begin
with STK[TOP] do
begin
if DTYPE <> TYPUA then
if DTYPE = TYPUN then ERROR (WNULLREF)
else if DTYPE = TYPUM then ERROR (WLOADING_STRING)
else ERROR (WNOT_AN_ADDR);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if FPA.WHICH = RGS then
ERROR (WINDEXING_IN_PARMS);
if I1 = 0 then MAXFINALIND := IND1 else MAXFINALIND := IND0;
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + I1;
INC_INDIRECTION(TOP, MAXFINALIND);
DTYPE := TYP;
DLENGTH := I2;
end (*with STK[TOP] do*);
end (*UILOD*);
UPLOD : (* als/peg 18jul79 *)
with CURPROCSPEC do
begin
if PROCTYPE <> TYP then
ERROR (WENT_AND_PLOD_INCONSISTENT);
if TYP <> TYPUP then
begin (*copy function result to RTB*)
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := BLOCKTABLE[I1];
VPA1.VPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (VPA1.VPA, MTYP);
if TYP = TYPUB then BREPRES := BINTVAL;
end (*with STK[TOP] do*);
MOVE_QUANTITY(OPNDRTB, TOP);
end (*copy function result*);
end (*UPLOD*);
end (*case OPC of*)
end (*LOAD1_STORE_OPS*);
(*** ANI_CLASS: LOAD2_STORE_OPS USTR UNSTR UISTR UINST UPSTR UMOV ***)
(**)
procedure LOAD2_STORE_OPS;
begin
case OPC of
USTR, UNSTR : (* als/peg 03jul79 *)
begin
if (I2 div QWBITS) mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if STK[TOP].DTYPE <> TYP then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUJ, TYPUL] then
begin
CVT_INT_DATUM(TOP);
TYP := LENGTH_TO_INTOPNDTYPE(I3);
end;
STK[TMPD1] := ZERODATUM;
with STK[TMPD1] do
begin
CODESTART := STK[TOP].CODESTART;
DTYPE := TYPUA;
DLENGTH := I3;
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end;
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
STORE (TMPD1, TOP);
if OPC = USTR then
begin
FREEDATUMREGS (TOP);
POPTOP;
end;
(* FREEDATUMREGS (TMPD1);*)(*This should be superfluous.*)
end (*USTR, UNSTR*);
UISTR, UINST : (* als/peg 06jul79 *)
begin (* Alignment??*)
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if STK[TOP].DTYPE <> TYP then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP-1].DTYPE <> TYPUA then
ERROR(WISTR_INST_NEEDS_ADDRS);
INCREMENT_DATUM(TOP-1, I1);
if TYP in [TYPUJ, TYPUL] then
begin
CVT_INT_DATUM(TOP);
TYP := LENGTH_TO_INTOPNDTYPE(I2);
end;
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
STORE(TOP-1, TOP);
FREEDATUMREGS(TOP-1);
if OPC = UINST then
begin
STK[TOP-1] := STK[TOP];
STK[TOP-1].DLENGTH := I2;
end
else (*OPC = UISTR*)
begin
FREEDATUMREGS(TOP);
POPTOP;
end;
POPTOP;
end (*UISTR, UINST*);
UPSTR : (* als/peg 13jul79 *)
begin
PSTRCOUNT := PSTRCOUNT + 1;
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end (*with STK[TOP] do*);
if PSTRCOUNT = CURPROCSPEC.PARMS_POPPED then
with CURPROCSPEC do
begin
PWORD := 0;
EXCESS := 0;
for I := 1 to PARMS_POPPED do
begin
if STK[TOP].MTYPE = R_SPACE then
if IS_DOUBLE[STK[TOP].DTYPE] then
PWORD := PWORD + 2
else PWORD := PWORD + 1
else if STK[TOP].MTYPE = M_SPACE then
EXCESS := EXCESS + STK[TOP].DLENGTH div WORDBITS
else ERROR(WNOT_IMPLEMENTED);
POPTOP;
end (*for*);
REGPARMAREA := PWORD*WORDUNITS;
(**** Do we want this↑ here??*)
RESERVE_PARMREGS(PWORD);
end (*with CURPROCSPEC*);
if EXCESS > 0 then
(*There were so many parms that we passed some in the caller's
stackframe regs. Copy them into the parm save area where
they belong. The caller has passed the address of the beginning
of the parameter block in RTB -- peg 13jul79. *)
if EXCESS <= MAXMOVMS then (*emit a MOVMS instruction*)
begin
ALLOCRG(S1RTB);
REG_OPERAND (OPNDR, S1RTB);
REGDISP_OPERAND (OPND2, DISPLAY, -OFFSET_IN_VARS);
EMITXOP(MOVMQ_N[EXCESS], OPNDR, OPND2);
FREERG_S(S1RTB);
end (*emit a MOVMS*)
(**** Note: this should probably use a loop of MOVMS instructions, as
does UMOV (q.v., below) -- peg.*)
else (*emit a BLKMOV*)
begin
(*make sure that the global zero
and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(* set up the destination address and length *)
REG_OPERAND (OPNDR1, succ(S1RCPL));
REGDISP_OPERAND (OPND2, DISPLAY, -OFFSET_IN_VARS);
EMITXOP (XMOV_A, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, EXCESS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
ALLOCRG(S1RTB);
REG_OPERAND (OPNDR1, S1RCPL);
REG_OPERAND (OPNDR2, S1RTB);
INSTLOC := NEWINSTREC;
EMITXOP (XBLKMOV, OPNDR1, OPNDR2);
FREERG_S(S1RTB);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*emit a BLKMOV*);
end (*UPSTR*);
UMOV :
begin
(* LCW 2AUG78
The strategy for UMOV is to do a BLKMOV if the transfer length is long
enough to justify the BLKMOV overhead, else to do a series of MOVMQs,
starting with the longest available MOVMQ and proceeding to the short
MOVMQs if necessary.
This procedure ignores the problem associated with having overlapping
source and destination where the source address is less than the
destination address. In that case, SOPA may destroy the source during
the MOV. However, if the source and destination overlap completely,
then SOPA will not destroy the source. Note that PASCAL and PCode do
not explicitly define the semantics of MOV when the source and
destination incompletely overlap.
*)
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not (STK[TOP-1].DTYPE in [TYPUA,TYPUM]) or
not (STK[TOP].DTYPE in [TYPUA,TYPUM]) then
ERROR (WMOV_NEEDS_ADDRS);
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
if I1 >= BLKMOV_THRESH then
begin (*generate BLKMOV*)
(*make sure that the global zero and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(S1RCPL));
MOVE_QUANTITY (OPNDR1, TOP-1);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
REG_OPERAND (OPNDR1, S1RCPL);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XBLKMOV, OPNDR1, OPND2);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*generate BLKMOV*)
else
begin (*generate MOVMQ*)
XFER_CNT := I1;
while XFER_CNT >= 128 do
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_128, OPND1, OPND2);
XFER_CNT := XFER_CNT - 128;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 128);
INCREMENT_DATUM (TOP, 128);
end;
end;
if XFER_CNT >= 64 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_64, OPND1, OPND2);
XFER_CNT := XFER_CNT - 64;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 64);
INCREMENT_DATUM (TOP, 64);
end;
end;
if XFER_CNT >= 32 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_32, OPND1, OPND2);
XFER_CNT := XFER_CNT - 32;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 32);
INCREMENT_DATUM (TOP, 32);
end;
end;
if XFER_CNT > 0 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (MOVMQ_N[XFER_CNT], OPND1, OPND2);
end;
end (*generate MOVMQ*);
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
POPTOP;
end (*PMOV*);
end (*case OPC of*)
end (*LOAD2_STORE_OPS*);
(*** ANI_CLASS: FLOW_CONTROL_OPS UTJP UFJP UUJP UXJP UGOOB ULAB UCLAB ***)
(**)
procedure FLOW_CONTROL_OPS;
begin
case OPC of
UTJP, UFJP : (* peg 02jul79 *)
begin
if TOP <> BOT then
ERROR (WTJP_FJP_WITH_NONEMPTY_STACK);
LABNUM := LABELNUMBER(NAM1);
with STK[TOP] do
begin
if DTYPE <> TYPUB then
ERROR (WTJP_FJP_NEEDS_BOOLEAN);
if BREPRES = BINTVAL then
if IS_CONSTANT(TOP) then
if ((OPC = UTJP) and (FPA.MEMADR.DSPLMT = 1))
or ((OPC = UFJP) and (FPA.MEMADR.DSPLMT = 0)) then
begin (*jump always*)
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end
else if ((OPC = UTJP) and (FPA.MEMADR.DSPLMT = 0))
or ((OPC = UFJP) and (FPA.MEMADR.DSPLMT = 1)) then
(*never jump*)
else ASSERTFAIL('UTJP,UFJP001')
else
begin (*non-constant bintval*)
if OPC = UTJP then S1OP := XJMPZ_NEQ_Q
else S1OP := XJMPZ_EQL_Q;
GET_OPERAND (OPND1, TOP);
JUMPLOC := NEWINSTREC;
EMITJOP (S1OP, 0, OPND1, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end (*non-constant bintval*)
else
begin (*bjump representation*)
if (BJUMPON and (OPC = UFJP))
or ((not BJUMPON) and (OPC = UTJP)) then
begin
INVERT_SKIP (BFALLTHRUSKIPLOC);
BJUMPON := not BJUMPON;
end;
if OPC = UFJP then
PTR := BTRUELIST.FIRST
else PTR := BFALSELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, NEWINSTREC);
PTR := NEXT;
end;
if OPC = UFJP then
PTR := BFALSELIST.FIRST
else PTR := BTRUELIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
JUMP_TO_LABEL_RECORD_OR_FIX (PTR, LABNUM);
PTR := NEXT;
end;
FALLTHRUJUMP := NEXT_INSTRUCTION(BFALLTHRUSKIPLOC);
JUMP_TO_LABEL_RECORD_OR_FIX (FALLTHRUJUMP, LABNUM);
end (*bjump representation*);
end (*with STK[TOP] do*);
FREEDATUMREGS (TOP);
POPTOP;
end (*UTJP, UFJP*);
UUJP : (* als/peg 28jun79 *)
begin
if TOP <> BOT-1 then
ERROR (WUJP_WITH_NONEMPTY_STACK);
JUMPLOC := NEWINSTREC;
PR_BIT := ord( JUMPTABLE_IN_PROGRESS );
EMITJOP (XJMPA, PR_BIT, UNUSED_OP, ZERO_OP, nil);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABELNUMBER(NAM1));
end (*UUJP*);
UXJP : (* peg 05jul79 *)
begin
(*XJP compiles into
SKP if too small to A
SKP if not too big to B
A: JUMP to default
B: JUMP to wherever(index) *)
if TOP <> BOT then
ERROR (WXJP_WITHOUT_SINGLETON_STACK);
if not IS_INTEGER[TYP] then
ERROR (WWRONG_INSTR_DATATYPE);
if not (TYP = STK[TOP].DTYPE) then
ERROR (WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUI, TYPUK] then
ERROR(WNOT_IMPLEMENTED);
LABNUM1 := LABELNUMBER(NAM1);
LABNUM2 := LABELNUMBER(NAM2);
if TYP in [TYPUJ, TYPUL] then CVT_INT_DATUM(TOP);
COERCE_DATUM (TOP, TYPUJ);
if IS_CONSTANT(TOP) then
begin
IMM_OPERAND (OPND, STK[TOP].FPA.MEMADR.DSPLMT);
EXTENDED_REGDISP_OPERAND
(OPND1, S1RPC, I1 - STK[TOP].FPA.MEMADR.DSPLMT)
(*Looks funny but it is compatible with
the negate-and-shift fixup which
must be done in the case of a
variable index.*)
end
else
begin
GET_SHORT_OPERAND (OPND, TOP);
OPND1 := OPND;
OPND1.X := 1;
OPND1.XW.V := 1;
OPND1.XW.S := DALIGNSHIFT;
OPND1.XW.REG := S1RPC;
OPND.XW.DISP := -I1;
end;
IMM_OPERAND(OPND2, I1);
SKIPSMALL := NEWINSTREC;
EMITSOP (XSKP_LSS_S, 0, OPND, OPND2, nil);
IMM_OPERAND(OPND2, I2);
SKIPNOTBIG := NEWINSTREC;
EMITSOP (XSKP_LEQ_S, 0, OPND, OPND2, nil);
JUMPDEFAULT := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JUMPINDEXED := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, OPND1, nil);
FIXSOP (SKIPSMALL, JUMPDEFAULT);
FIXSOP (SKIPNOTBIG, JUMPINDEXED);
JUMP_TO_LABEL_RECORD_OR_FIX (JUMPDEFAULT, LABNUM2);
ADD_CODEPTR_TO_CODELIST (NEG_SHIFT_FIXLIST, JUMPINDEXED);
(*All OPND2s on this fixup list will have the displacement
in the extended word negated and arithmetically shifted
to make it a doubleword index.*)
JUMP_TO_TABLE_RECORD_OR_FIX (JUMPINDEXED, LABNUM1);
FREEDATUMREGS (TOP);
POPTOP;
end (*UXJP*);
UGOOB :
begin
(* NOTE: This instruction cuts back the RUNTIME stack, going back through
the DYNAMIC links to find the correct lexical level. We'll have to generate
an external fixup for the linker, since the destination has not been seen
yet and won't be during this segment -- peg.*)
ERROR (WNOT_IMPLEMENTED);
end (*UGOOB*);
ULAB, UCLAB : (* peg 02jul79 *)
(* Note: LAB operand, branch count, is in I1. If this value is 1 we might
rearrange the code, or perhaps the Optimizer should do it. ALS *)
begin
if TOP <> BOT - 1 then
ERROR(WSTACK_NON_EMPTY);
UPD_LBLTBL (LPTR, LABELNUMBER(NAM0), LCODEPTR);
with LPTR↑ do
begin
if DEFINED then ERROR (WMULT_DEFINED_LAB);
DEFINED := true;
if OPC = ULAB then BRANCH_CNT := I1; (* peg 02jul79 *)
CODEPTR := NEWINSTREC;
if JUMPTABLELABEL then JUMPTABLE_IN_PROGRESS := true;
PTR := JLIST.FIRST;
while PTR <> nil do
begin
NEXT := JUMPSKIPDEST(PTR);
FIXJOP (PTR, CODEPTR);
PTR := NEXT
end;
JLIST := EMPTYJUMPLIST;
end (*with LPTR↑ do*);
%* if OPC = UCLAB then (*What is this garbage???! peg 25jul*)
begin
UPD_LBLTBL (LPTR, -1, LINTVAL); (* lower case boundary is always 0 *)
with LPTR↑ do
begin
DEFINED := true;
INTVAL := 0;
FIXOPND2 (CLIST.FIRST↑.CODEPTR, INTVAL);
CLIST := EMPTYCODELIST;
end (*with LPTR↑ do*);
UPD_LBLTBL (LPTR, -2, LINTVAL); (* upper case boundary *)
with LPTR↑ do
begin
DEFINED := true;
INTVAL := I1-1;
FIXOPND2 (CLIST.FIRST↑.CODEPTR, INTVAL);
CLIST := EMPTYCODELIST;
end (*with LPTR↑ do*);
end; *\ (*...end garbage*)
end (*ULAB, UCLAB*);
end (*case OPC of*)
end (*FLOW_CONTROL_OPS*);
(*** ANI_CLASS: ENVIRONMENT_OPS UBGN UEND USTP UENT UBGNB UENDB ***)
(**)
procedure ENVIRONMENT_OPS;
begin
case OPC of
UBGN :
begin (* als/peg 05jul79 *)
CURPROG := NAM1;
end (*UBGN*);
USTP : (* als/peg 05jul79 *)
begin
if NAM1 <> CURPROG then
ERROR(WBGN_STP_NAME_MISMATCH);
end (*USTP*);
UEND : (* als/peg 05jul79 *)
begin
if NAM1 <> CURPROCXN then
ERROR(WENT_END_NAME_MISMATCH);
if PSTRCOUNT <> CURPROCSPEC.PARMS_POPPED then
ERROR(WENT_SPECIFIED_WRONG_PARMS);
if TOP > BOT - 1 then
while TOP >= BOT do POPTOP;
GEN_SEGMENT;
end (*UEND*);
UENT : (* als/peg 13jul79 *)
begin
CURPROCXN := NAM0;
CURLVL := I1;
CURPROC := NAM0.NAM;
INIT_SEGMENT;
PSTRCOUNT := 0; (* Set here to use as check in UPSTR and UEND. *)
if I1 <= 0 then
ERROR (WINVALID_LEVEL)
else if I1 > MAXLVLUSED then
begin
MAXLVLUSED := I1;
MINDSPS1REG := MAXDSPS1REG - (MAXLVLUSED-1);
CHECK_DSP_TMP_COLLISION
end;
DISPLAY := LVL_TO_S1REG[CURLVL];
if DISPLAY < MINDSPS1REG then ASSERTFAIL('UENT 001');
BLOCKTABLE[I2] := CURLVL;
with CURPROCSPEC do
begin
PROCTYPE := TYP;
PROCNAM := CURPROCXN;
PARMS_POPPED := I3;
if PARMS_POPPED = 0 then
RESERVE_PARMREGS(0);
RESULTS_PUSHED := I4;
if not DEBUG then
begin
REG_OPERAND (OPNDR, DISPLAY);
if CURLVL = 1 then
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP, L1DISPLAY_OFFSET
(*+ eval save size by fixup*) )
else (*CURLVL > 1*)
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP, DISPLAY_OFFSET
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
if CURLVL = 1 then
EXTENDED_IMM_OPERAND(OPND2, FILBUFAREASIZE)
else (*CURLVL > 1*)
EXTENDED_IMM_OPERAND(OPND2, REGIMAGEAREASIZE);
INSTLOC := NEWINSTREC;
EMITXOP (XADJSP_UP, OPNDRSP, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
ADD_CODEPTR_TO_CODELIST (STACKFRAME.FIXLIST, INSTLOC);
(**** Note: this will have to have the expr. temp. stack and large callee
parm. area sizes fixed up, too--peg*)
end
else (*DEBUG*)
begin (*allocate extra word for callee segment base save*)
REG_OPERAND (OPNDR, DISPLAY);
if CURLVL = 1 then
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP,
L1DISPLAY_OFFSET + WORDUNITS
(*+ eval save size by fixup*) )
else (*CURLVL > 1*)
EXTENDED_REGDISP_OPERAND (OPND2, S1RSP,
DISPLAY_OFFSET + WORDUNITS
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
if CURLVL = 1 then
EXTENDED_IMM_OPERAND (OPND2, FILBUFAREASIZE + WORDUNITS)
else (*CURLVL > 1*)
EXTENDED_IMM_OPERAND (OPND2, REGIMAGEAREASIZE + WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XALLOC_1, OPND1, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.FIXLIST, INSTLOC);
ADD_CODEPTR_TO_CODELIST (STACKFRAME.FIXLIST, INSTLOC);
(**** And expr. temp. and parm. area lists???*)
EXTENDED_REGDISP_OPERAND (OPND2, S1RPC, 0);
EMITXOP (XMOV_A, OPND1, OPND2);
(*OPND2 needs to be fixed up by subtracting this
instruction's displacement in the segment. The
code concretizer will do this automatically
because it normalizes *all* PC-relative addresses
to the beginning of the segment.*)
end (*allocate extra word*);
end (*with CURPROCSPEC...*);
end (*UENT*);
UBGNB : (* peg 09jul79 *)
begin
if CURFRAME >= MAXFRAME then
ERROR(W2_MANY_BGNBS);
PUSH_STKFRAME;
end (*UBGNB*);
UENDB : (* peg 09jul79 *)
begin
if CURFRAME <= MINFRAME then
ERROR(W2_MANY_ENDBS);
POP_STKFRAME;
end (*UENDB*);
end (*case OPC of*)
end (*ENVIRONMENT_OPS*);
(*** ANI_CLASS: CHECK_OPS UCHKL UCHKH UCHKT UCHKF UCHKN ***)
(**)
procedure CHECK_OPS;
begin
case OPC of
UCHKH, UCHKL : (* peg 07jul79 *)
(*Note: peephole optimizer will optimize the case where a CHKL
is followed immediately by a CHKH on the same item. Also,
this routine needs to be modified when our error codes are
standardized -- peg.*)
begin
if not (STK[TOP].DTYPE in
[TYPUA, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL, TYPUS]) then
ERROR(WCHECKING_INVALID_TYPE);
if not ((STK[TOP].DTYPE = TYP)
or ((STK[TOP].DTYPE = TYPUN) and (TYP = TYPUA))) then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUI, TYPUK, TYPUS] then ERROR(WNOT_IMPLEMENTED);
if TYP = TYPUC then
begin
if SLGTH <> 1 then ASSERTFAIL('UCHKL,UCH001');
I1 := ord(SVAL[1]) - CHARDIF;
end;
if IS_CONSTANT(TOP) then
begin
if ((OPC = UCHKH) and (STK[TOP].FPA.MEMADR.DSPLMT > I1))
or ((OPC = UCHKL) and (STK[TOP].FPA.MEMADR.DSPLMT < I1)) then
ERROR(WCHECKED_CONSTANT_OUT_OF_RANGE);
end
else (*not constant*)
begin
if OPC = UCHKH then
begin
LOWBOUND := MIN_ON_COMP_MACH + 1; (**** This is a kludge -- *)
HIGHBOUND := I1; (* als/peg 31jul79*)
end (*OPC = UCHKH*)
else (*OPC = UCHKL*)
begin
LOWBOUND := I1;
HIGHBOUND := MAX_ON_COMP_MACH;
end;
GET_OPERAND(OPND2, TOP);
EXTENDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, LOWBOUND, HIGHBOUND, TYP);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_B_X[TYP],OPND1,OPND2);
end (*not constant*);
end (*UCHKL, UCHKH*);
UCHKF, UCHKT : (* peg 07jul79 *)
begin
with STK[TOP] do
begin
if DTYPE <> TYPUB then ERROR(WCHKF_CHKT_NEEDS_BOOLEAN);
if IS_CONSTANT(TOP) then
begin
if (OPC = UCHKF) and (FPA.MEMADR.DSPLMT = 1) then
ERROR(WBOOL_IS_TRUE)
else if (OPC = UCHKT) and (FPA.MEMADR.DSPLMT = 0) then
ERROR(WBOOL_NOT_TRUE);
end (*constant*)
else
begin (*non-constant*)
if BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP);
if OPC = UCHKF then
begin
LOWBOUND := 0;
HIGHBOUND := 0;
end
else (*UCHKT*)
begin
LOWBOUND := 1;
HIGHBOUND := 1;
end;
GET_OPERAND(OPND2, TOP);
EXTENDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, HIGHBOUND, 0, TYPUB);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_N_X[LOWBOUND, TYPUB], OPND1, OPND2);
end (*not constant*);
end;
FREEDATUMREGS(TOP);
POPTOP;
end (*UCHKF, UCHKT*);
UCHKN : (* peg 07jul79 *)
begin
if STK[TOP].DTYPE = TYPUN then
ERROR(WCHKN_NULL_TOP)
else if STK[TOP].DTYPE <> TYPUA then
ERROR(WCHKN_NOT_ADDRESS);
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT < 0 then (*nil*)
ERROR(WCHKN_NULL_TOP);
end (*constant*)
else
begin (*not constant*)
HIGHBOUND := MAXS1ADDR;
GET_OPERAND(OPND2, TOP);
EXTENDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, HIGHBOUND, 0, TYPUA);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_N_X[0, TYPUA], OPND1, OPND2);
end (*not constant*);
end (*UCHKN*);
end (*case OPC of*)
end (*CHECK_OPS*);
(*** ANI_CLASS: TYPE_CONV_OPS URND UTYP UTYP2 UCVT UCVT2 ***)
(**)
procedure TYPE_CONV_OPS;
begin
case OPC of
URND : (* peg 21jul79 *)
begin
if not ((IS_INTEGER[TYP]) and (IS_REAL[TYPO2])) then
ERROR(WWRONG_INSTR_DATATYPE);
if not IS_REAL[STK[TOP].DTYPE] then
ERROR(WFIX_OF_INVALID_TYPE);
if TYPO2 <> STK[TOP].DTYPE then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
COERCE_DATUM(TOP, TYP);
end (*URND*);
UTYP, UTYP2 : (* als/peg 19jul79 *)
begin
if OPC = UTYP then STE := TOP else STE := TOP-1;
with STK[STE] do
begin
if DTYPE <> TYPO2 then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYPO2 in [TYPUB, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL, TYPUS] then
case TYPO2 of
TYPUB : NO_ERROR := TYP in [TYPUJ, TYPUL];
TYPUC : NO_ERROR := TYP in [TYPUJ, TYPUL];
TYPUI : NO_ERROR := TYP in [TYPUK, TYPUS];
TYPUJ : NO_ERROR := TYP in [TYPUC, TYPUL, TYPUS];
TYPUK : NO_ERROR := TYP in [TYPUJ, TYPUS];
TYPUL : NO_ERROR := TYP in [TYPUC, TYPUJ, TYPUS];
TYPUS : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL];
end (*case*)
else NO_ERROR := false;
if not NO_ERROR then ERROR(WTYP_WITH_INVALID);
if TYP = TYPUS then (*Not implemented until *)
ERROR(WNOT_IMPLEMENTED) (* more than one length of *)
else if TYPO2 = TYPUS then (* sets exist. *)
ERROR(WNOT_IMPLEMENTED);
DTYPE := TYP;
end (*with STK[STE] do*);
end (*UTYP,UTYP2*);
UCVT, UCVT2 : (* peg 06jul79 *)
begin
if OPC = UCVT then STE := TOP else STE := TOP-1;
if STK[STE].DTYPE <> TYPO2 then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYPO2 in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUQ, TYPUR] then
case TYPO2 of
TYPUI : NO_ERROR := TYP in [TYPUC, TYPUJ, TYPUQ, TYPUR];
TYPUJ : NO_ERROR := TYP in [TYPUI, TYPUQ, TYPUR];
TYPUK : NO_ERROR := TYP in [TYPUC, TYPUL, TYPUQ, TYPUR];
TYPUL : NO_ERROR := TYP in [TYPUK, TYPUQ, TYPUR];
TYPUQ : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUR];
TYPUR : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUQ];
end (*case*)
else NO_ERROR := false;
if NO_ERROR then
begin
if TYPO2 in [TYPUJ, TYPUL] then
if IS_REAL[TYP] then
COERCE_INT_DATUM(STE)
else CVT_INT_DATUM(STE);
COERCE_DATUM(STE, TYP);
end
else ERROR(WCVT_WITH_INVALID);
end (*UCVT, UCVT2*);
end (*case OPC of*)
end (*TYPE_CONV_OPS*);
(*** ANI_CLASS: VIRT_STK_OPS UDUP USWP UIXA ***)
(**)
procedure VIRT_STK_OPS;
begin
case OPC of
UDUP : (* als/peg 02jul79 *)
begin
if TOP < BOT then ERROR(WDUP_ON_EMPTY_STACK);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if TYP <> STK[TOP].DTYPE THEN ERROR (WINSTR_TYPE_NOT_DATUM_TYPE);
if IS_DOUBLE[STK[TOP].DTYPE] then FINDRP else FINDRG;
OPRRG := NXTRG;
RESCODESTART := NEWINSTREC;
REG_OPERAND(OPNDR, OPRRG);
MOVE_QUANTITY(OPNDR, TOP);
PUSHTOP;
REG_DATUM(TOP, RESCODESTART, TYP, OPRRG);
end(*UDUP*);
USWP : (* als/peg 02jul79 *)
begin
if TOP <= BOT then ERROR(WSWP_NOT_2);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not (TYPO2 in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if ((STK[TOP].DTYPE <> TYP) or (STK[TOP-1].DTYPE <> TYPO2)) then
ERROR(WSWP_TYP_ERROR);
BOOL_IN_STK := false; (* All of this may or may not *)
for STE := BOT to TOP do (* accomplish what we want it to, *)
if STK[STE].DTYPE = TYPUB then (* which is to prevent codefork *)
BOOL_IN_STK := true; (* side effects.*)
if BOOL_IN_STK then
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
XCHANGE_STKENTS (TOP, TOP-1);
end(*USWP*);
UIXA : (* als/peg 29Jun79 *)
begin
if not (STK[TOP-1].DTYPE in [TYPUA, TYPUM]) then
ERROR(WIXA_NEEDS_ADDR);
if TYP in [TYPUI, TYPUK] then
ERROR(WNOT_IMPLEMENTED);
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
%* with STK[TOP] do
if DTYPE in [TYPUB, TYPUC] then
begin
if (DTYPE=TYPUB) and (BREPRES=BJUMP) then
BJUMP_TO_BINTVAL (TOP);
DTYPE := TYPQ;
end; *\
if TYP in [TYPUJ, TYPUL] then
COERCE_INT_DATUM(TOP);
(*Multiply top of stack by I1.*)
with STK[TOP] do
if I1 <> 1 then
begin
COMBINABLE := false;
CALCULABLE := false;
SHIFTDIST := POWER2(I1);
RESCODESTART := CODESTART;
repeat
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or
((NVPAS=1) and (VPA1.VSHIFT+SHIFTDIST<=SFLDMAX)))
or
IS_CONSTANT(TOP)
then
COMBINABLE := true
else if IS_CONST_PLUS_OPND(TOP) then
begin (*index is uncomplicated*)
CONSTPART := FPA.MEMADR.DSPLMT * I1;
FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, I1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('UIXA 001');
CALCULABLE := true
end (*index is uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if TOOMUCH2 then
SIMPLIFY (TOP)
else
begin
CONSTPART := 0;
IMM_OPERAND (OPND1, I1);
CALCULABLE := true;
end;
end (*general case*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP);
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, TYPUJ, DEST);
FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT * I1;
if not ((NVPAS<=1) or (I1=1)) then ASSERTFAIL('UIXA 002');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART
end (*COMBINABLE*);
end (*with STK[TOP] do*);
(*Simplify datums until combinable. We cannot emit an add
to combine them since the result must be
an address, with its high order bits zero.*)
if IS_CONSTANT(TOP) and
(STK[TOP].FPA.MEMADR.DSPLMT = 0) then
(*index is zero so just discard it*)
else
begin (*non-zero index*)
while STK[TOP].FINALIND > IND0 do
SIMPLIFY (TOP);
while STK[TOP-1].FINALIND > IND0 do
SIMPLIFY (TOP-1);
if STK[TOP-1].NVPAS > 0 then
while STK[TOP].NVPAS > 1 do
SIMPLIFY (TOP);
if STK[TOP].NVPAS > 0 then
while STK[TOP-1].NVPAS > 1 do
SIMPLIFY (TOP-1);
if not ((STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) and
(STK[TOP].FPA.MEMADR.LVL = 0) and
(STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) ) then
ASSERTFAIL('UIXA 003');
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT + STK[TOP].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
case STK[TOP].NVPAS of
0 : (*null case*);
1 : STK[TOP-1].VPA1 := STK[TOP].VPA1;
2 : begin
STK[TOP-1].VPA1 := STK[TOP].VPA1;
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
end (*case*)
else if STK[TOP-1].NVPAS = 1 then
begin
if STK[TOP].NVPAS = 1 then
STK[TOP-1].VPA2 := STK[TOP].VPA1
end;
STK[TOP-1].NVPAS :=
STK[TOP-1].NVPAS + STK[TOP].NVPAS;
end (*non-zero index*);
if RTBUSER = TOP then RTBUSER := TOP - 1;
POPTOP;
end (*UIXA*);
end (*case OPC of*)
end (*VIRT_STK_OPS*);
(*** ANI_CLASS: PROC_CALL_OPS UMST UPAR UCUP UICUP UCSP URET ***)
(**)
procedure PROC_CALL_OPS;
begin
case OPC of
UMST : (* als/peg 17jul79 *)
begin
if MSTTOP >= MAXMST then
ERROR (WFUNC_CALLS_NESTED_TOO_DEEPLY)
else
begin
MSTTOP := MSTTOP + 1;
with MSTSTK[MSTTOP] do
begin
DESTLEV := I1;
MSTCODESTART := NEWINSTREC;
if MSTTOP = 1 then
CURPARMREGS := CURRENT_PARMREG_COUNT
else CURPARMREGS := MIN(MAXPAREG, PWORDCOUNT);
end (*with MSTSTK[MSTTOP]*);
if (MSTTOP = 1) and (MSTSTK[MSTTOP].CURPARMREGS > 0) then
SAVE_PARMREGS;
PWORDCOUNT := 0;
if CURLVL = 1 then
OFFSET := FILE_OFFSET
else (*CURLVL > 1*)
OFFSET := R_OFFSET;
DSPL := MSTSTK[MSTTOP-1].EVALSAVESTART;
for STE := BOT to TOP do (*Save expression stack*)
with STK[STE] do
if NVPAS > 0 then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin (*Save BJUMP temp reg just in case used*)
DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND(OPND1, DISPLAY, OFFSET - DSPL);
REG_OPERAND(OPNDR, VPA1.VPA.RGADR);
EMITXOP(XMOV_S_S, OPND1, OPNDR)
end (*Save BJUMP temp reg*)
else
begin
(*This datum's value may be susceptible to
change by side effect. Get it into eval
save area to protect it.*)
if IS_DOUBLE[DTYPE] then
DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND(OPND1, DISPLAY, OFFSET - DSPL);
MOVE_QUANTITY (OPND1, STE);
(**** Note: check for *)if not DATUM_IS_T_REG(STE)
(* non-reg. expr. temp*) and not DATUM_IS_FILADR(STE) then
begin (*arrange to restore it to a temp*)
if IS_DOUBLE[DTYPE] then FINDRP
else FINDRG;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
end;
end (*get datum into eval save*);
FREE_TEMP_REGS;
RESERVE_PARMREGS(0);
MSTSTK[MSTTOP].EVALSAVESTART := DSPL;
if DSPL > EVALSAVE.SIZE then EVALSAVE.SIZE := DSPL;
PUSH_STKFRAME;
end (*no error*);
end (*UMST*);
UPAR : (*peg 09aug79*)
begin
if TYP <> STK[TOP].DTYPE then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE = TYPUB then
if STK[TOP].BREPRES = BJUMP then
BJUMP_TO_BINTVAL(TOP);
if not ((PWORDCOUNT >= MAXPAREG)
or ((PWORDCOUNT = MAXPAREG) and (IS_DOUBLE[TYP]))) then
begin (*reg. parm*)
PREG := MINPARS1REG + PWORDCOUNT;
CORRECT := false;
LOADSTKENTRY(TOP); (*This may get it into the correct reg.*)
if DATUM_IS_REG(TOP) then
if STK[TOP].VPA1.VPA.RGADR = PREG then
CORRECT := true;
if not CORRECT then (*move parameter to correct reg.*)
with MSTSTK[MSTTOP] do
begin
if not RISFREE[PREG] then ASSERTFAIL('UPAR 001');
if IS_DOUBLE[TYP] then
begin
if not RISFREE[succ(PREG)] then ASSERTFAIL('UPAR 002');
ALLOCRP(PREG);
S1OP := MOVMS_N[2];
end
else
begin
ALLOCRG(PREG);
S1OP := XMOV_S_S;
end;
GET_OPERAND(OPND2, TOP);
RESCODESTART := STK[TOP].CODESTART;
REG_OPERAND(OPND1, PREG);
EMITXOP(S1OP, OPND1, OPND2);
FREEDATUMREGS(TOP);
REG_DATUM(TOP, RESCODESTART, TYP, PREG);
end (*move parameter*);
end (*reg. parm*);
if IS_DOUBLE[TYP] then
PWORDCOUNT := PWORDCOUNT + 2
else
PWORDCOUNT := PWORDCOUNT + 1;
end (*UPAR*);
UCUP : (*peg 09aug79*)
begin
if (TOP - BOT) + 1 < I2 then
ERROR(W2_MANY_PARMS_SPECIFIED)
else if (TOP - BOT) + 1 > I2 then
ERROR(WINSUFF_PARMS_SPECIFIED);
if not ((IS_INTEGER[TYP]) or (IS_REAL[TYP])
or (TYP in [TYPUA, TYPUB, TYPUC, TYPUP])) then
ERROR(WILLEGAL_PROC_TYPECODE);
if ((TYP = TYPUP) and (I3 <> 0))
or ((IS_INTEGER[TYP] or IS_REAL[TYP]
or (TYP in [TYPUA, TYPUB, TYPUC])) and (I3 <> 1)) then
ERROR(WWRONG_RESULT_NUMBER);
PARM := BOT;
LASTREGPARM := PARM;
PWORDCOUNT := 0;
EXCESS := 0;
while PARM <= TOP do
begin (*check reg. parms for correct order, collect excess*)
if (PWORDCOUNT >= MAXPAREG)
or ((PWORDCOUNT = MAXPAREG) and (IS_DOUBLE[TYP])) then
if IS_DOUBLE[STK[PARM].DTYPE] then
EXCESS := EXCESS + DOUBLEWORDUNITS
else EXCESS := EXCESS + WORDUNITS
else
begin (*reg. parm*)
LASTREGPARM := PARM;
PREG := MINPARS1REG + PWORDCOUNT;
if not (DATUM_IS_REG(PARM)
and (STK[PARM].VPA1.VPA.RGADR = PREG)) then
ASSERTFAIL('UCUP 001');
end (*reg. parm*);
if IS_DOUBLE[STK[PARM].DTYPE] then
PWORDCOUNT := PWORDCOUNT + 2
else PWORDCOUNT := PWORDCOUNT + 1;
PARM := PARM + 1;
end (*check reg. parms*);
MINTMPS1REG := PREG + 1;
MAXTMPS1REG := MAX(MAXTMPS1REG,MINTMPS1REG-1);
CHECK_DSP_TMP_COLLISION;
if EXCESS > 0 then (* move excess parms to stack top, *)
begin (* pass address of overflow area in RTB *)
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRG(S1RTB);
EMITXOP(XMOV_S_S, OPNDRTB, OPNDRSP);
IMM_OPERAND(OPND2, EXCESS);
EMITXOP(XADJSP_UP, OPNDRSP, OPND2);
DSPL := -EXCESS;
for PARM := LASTREGPARM + 1 to TOP do
begin
REGDISP_OPERAND(OPND1, S1RSP, DSPL);
MOVE_QUANTITY(OPND1, PARM);
if IS_DOUBLE[STK[PARM].DTYPE] then
DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
end;
FREERG_S(S1RTB);
end (*move excess parms*);
REG_OPERAND(OPNDR, LVL_TO_S1REG[MSTSTK[MSTTOP].DESTLEV]);
EXT_REGADDR_OPERAND(OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
UPD_PROCTBL(OPND2.FIXPTR, NAM1.NAM);
EMITJOP(XJSR, 0, OPNDR, OPND2, nil);
if EXCESS > 0 then (*restore SP*)
begin
IMM_OPERAND(OPND2, EXCESS);
EMITXOP(XADJSP_DN, OPNDRSP, OPND2);
end (*restore SP*);
while TOP >= BOT do (*free parm regs. ...*)
with STK[TOP] do
begin
if DATUM_IS_REG(TOP) then FREERG_S(VPA1.VPA.RGADR)
else FREEDATUMREGS(TOP);
POPTOP;
end; (*... free parm regs.*)
FREE_TEMP_REGS;
if MSTTOP > 1 then
begin
PWORDCOUNT := MSTSTK[MSTTOP].CURPARMREGS;
RESERVE_PARMREGS(0);
end
else
RESERVE_PARMREGS(MSTSTK[MSTTOP].CURPARMREGS);
POP_STKFRAME;
with MSTSTK[MSTTOP-1], CURPROCSPEC do
begin (*Restore expr stack and parmregs.*)
RTBSAVED := false;
if CURLVL = 1 then
OFFSET := FILE_OFFSET
else (*CURLVL > 1*)
OFFSET := R_OFFSET;
DSPL := EVALSAVESTART;
for STE := BOT to TOP do
with STK[STE] do
if NVPAS > 0 then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin (*Restore BJUMP temp reg*)
REG_OPERAND(OPNDR, VPA1.VPA.RGADR);
DSPL := DSPL + WORDUNITS;
ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - DSPL);
EMITXOP(XMOV_S_S,OPNDR,OPND2)
end (*Restore BJUMP temp reg*)
else
begin (*Restore one expr temp.*)
if not (DATUM_IS_T_REG(STE) or DATUM_IS_FILADR(STE) ) then
ASSERTFAIL('UCUP 002');
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if TOOMUCH1 then ASSERTFAIL('UCUP 003');
if IS_DOUBLE[DTYPE] then DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
if (TYP<>TYPUP) and IS_RTB(OPND1) then
begin
(*We will be getting a function value back in
RTB, so remember to restore the thing
which was there into another temporary,
after restoring all the others so we know
which ones are available.*)
RTBSAVED := true;
RTBDATUM := STE;
RTBDSPL := DSPL;
end (*RTB*)
else
begin (*ordinary temporary*)
if DATUM_IS_T_REG(STE) then
if IS_DOUBLE[DTYPE] then
ALLOCRP(VPA1.VPA.RGADR)
else ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - DSPL);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2);
end (*ordinary temp reg*);
end (*restore one expr temp*);
if RTBSAVED then
with STK[RTBDATUM] do
begin (*Restore it somewhere else*)
if IS_DOUBLE[DTYPE] then
begin FINDRP; S1OP := XMOV_D_D; end
else
begin FINDRG; S1OP := XMOV_S_S; end;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPNDR, NXTRG);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - RTBDSPL);
EMITXOP (S1OP, OPNDR, OPND2);
end (*if RTBSAVED*);
if MSTTOP = 1 then RESTORE_PARMREGS;
end (*Restore expr stack and parmregs.*);
if TYP <> TYPUP then
begin (*Function value being returned in RTB.*)
PUSHTOP;
if IS_DOUBLE[TYP] then ALLOCRP (S1RTB) else ALLOCRG (S1RTB);
REG_DATUM (TOP, MSTSTK[MSTTOP].MSTCODESTART, TYP, S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[TYP];
end (*function value being returned*);
MSTTOP := MSTTOP - 1;
end (*UCUP*);
UICUP :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UICUP*);
UCSP : CALLSTANDARD;
URET : (* als/peg 29Jun79 *)
with CURPROCSPEC do
begin
REG_OPERAND (OPNDR, DISPLAY);
if DEBUG then
begin
if CURLVL = 1 then
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - L1DISPLAY_OFFSET
(*- Eval save size by fixup*) )
else (*CURLVL > 1*)
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - DISPLAY_OFFSET
(*- Eval save size by fixup*) );
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_S_S, OPND1, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
if CURLVL = 1 then
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - L1DISPLAY_OFFSET
(*LCW) (*- Eval save size by fixup*) )
else (*CURLVL > 1*)
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) );
end
else
if CURLVL = 1 then
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY, -L1DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) )
else (*CURLVL > 1*)
EXTENDED_REGDISP_OPERAND (OPND2, DISPLAY, -DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XRETSR, OPNDR, OPND2);
ADD_CODEPTR_TO_CODELIST (EVALSAVE.NEGFIXLIST, INSTLOC);
end (*URET*);
end (*case OPC of*)
end (*PROC_CALL_OPS*);
(*** ANI_CLASS: IMP_EXP_OPS UIMPP UIMPV UEXPP UEXPV ***)
(**)
procedure IMP_EXP_OPS;
begin
case OPC of
UIMPP :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UIMPP*);
UIMPV :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UIMPV*);
UEXPP :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UEXPP*);
UEXPV :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UEXPV*);
end (*case OPC of*)
end (*IMP_EXP_OPS*);
(*** ANI_CLASS: COMP_TIME_OPS UCOMM UOPTN ULEX USYM ULIVE UDEAD UDOA UDEF UMDEF ULOC ***)
(**)
procedure COMP_TIME_OPS;
begin
case OPC of
UCOMM : (* als/peg 29Jun79 *)
begin
(* COMM is currently a no-op. *)
end (*UCOMM*);
UOPTN : (*only enough letters used to disambiguate*)
begin
if NAM1.NAM[1] = 'T' then
begin
NO_ERROR := true;
if NAM1.NAM[2] = 'A' then ASM := I1 = 1
else if NAM1.NAM[2] = 'D' then DEBUG := I1 = 1
else if NAM1.NAM[2] = 'M' then
begin
if I1 = 0 then TR_MST := false
else if I1 = 1 then TR_MST := true
else if I1 < 0 then
PRINT_MSTENTRY (-I1)
else NO_ERROR := false;
end
%* else if NAM1.NAM[2] = 'N' then (* commented out -- peg 18jul79 *)
begin
if I1 = 0 then TR_NEST := false
else if I1 = 1 then TR_NEST := true
else PRINT_NESTITEM (I1)
end *\(*end comment out *)
else if NAM1.NAM[2] = 'P' then
begin
if NAM1.NAM[6] = 'H' then
if I2 = 1 then NO_JMPX_TO_JMPA_FLG := I1 = 0
else if I2 = 2 then NO_SKIP_JMPA_FLG := I1 = 0
else if I2 = 3 then NO_COLLAPSE_MOV_FLG := I1 = 0
else if I2 = 4 then (*INC-SKP/INC-JMP option*)
else NO_ERROR := false
else if NAM1.NAM[6] = 'O' then TR_PEEPHOLE := I1 = 1
else if NAM1.NAM[6] = 'T' then (*Optimizations tracing option*)
else NO_ERROR := false;
end
else if NAM1.NAM[2] = 'S' then
begin
if NAM1.NAM[3] = '1' then
if I1 = 0 then TR_S1CODE := false
else if I1 = 1 then TR_S1CODE := true
else if I1 = -1 then
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE (S1PC, IPTR);
IPTR := NEXT_INSTRUCTION (IPTR);
end;
end
else NO_ERROR := false
else if NAM1.NAM[3] = 'I' then
if I1 = 0 then TR_SIMP := false
else if I1 = 1 then TR_SIMP := true
else if I1 < 0 then SIMPLIFY (-I1)
else NO_ERROR := false
else if NAM1.NAM[3] = 'T' then
if I1 = 0 then TR_STACK := false
else if I1 = 1 then TR_STACK := true
else if I1 < 0 then PRINTDATUM (-I1)
else NO_ERROR := false
else NO_ERROR := false;
end
else if NAM1.NAM[2] = 'U' then TR_UCODE := I1 = 1
else NO_ERROR := false;
if (not NO_ERROR) and TR_UCODE then
writeln(OUTPUT,'*** WARNING: Invalid or unrecognized OPTN ***');
end;
end (*UOPTN*);
ULEX : (* als/peg 09jul79 *)
begin
if (I2 < MINBLOCK) or (I2 > MAXBLOCK) then
ERROR(WINVAL_BLOCK_NUMBER);
BLOCKTABLE[I2] := I1;
end (*ULEX*);
USYM : (* als/peg 09jul79 *)
begin
(* NOTE: this instruction will remain unimplemented until some specifications
for a symbolic debugger and the information it needs (and where it will go,
etc.) have been created -- als/peg.*)
(* SYM is currently a no-op. *)
end (*USYM*);
ULIVE : (* als/peg 09jul79 *)
begin
(* LIVE is currently a no-op. *)
end (*ULIVE*);
UDEAD : (* als/peg 09jul79 *)
begin
(* DEAD is currently a no-op. *)
end (*UDEAD*);
UDOA : (* als/peg 09jul79 *)
begin
(* DOA is currently a no-op. *)
end (*UDOA*);
UDEF : (* als/peg 13jul79 *)
begin
if I1 mod WORDBITS <> 0 then
ERROR(WALIGNMENT_ERROR);
with CURPROCSPEC do
if MTYP = R_SPACE then
begin
REGPARMAREA := I1 div QWBITS;
R_MEMORY_AREA := -R_OFFSET*QWBITS;
end
else if MTYP = M_SPACE then
begin
M_MEMORY_AREA := I1;
STACKFRAME.SIZE := STACKFRAME.SIZE + (I1 div QWBITS);
end
else ERROR (WNOT_IMPLEMENTED);
end (*UDEF*);
UMDEF :
begin
(* NOTE: See Universal P-Code Definition, version [0.2] for details on
this instruction. A minimum implementation, allowing consistency checks
between this instruction and memory usage, should be easily implementable,
but requires some new data structures and routines; these should be care-
fully thought out -- peg.*)
end (*UMDEF*);
ULOC : (**** als should fix this.*)
(* LOC <line number> <page number> <stmt count> <basblock?>
where:
<line number> and <page number> refer to the original PASCAL source file.
<stmt count> is the number of the statement in that line
<basblock?> is one if this is the first statement of a basic block,
zero otherwise.*)
begin
CURPLOC := I1;
(*A 'LOC 0' precedes each procedure, at which time the code list
has not yet been initialized. Hence do not emit a ULOC fake
instruction in that case.*)(**** Is this still true??*)
if I1 > 0 then
begin
if DEBUG then EMITFAKEINST (XPLOC, I1);
end;
end (*ULOC*);
end (*case OPC of*)
end (*COMP_TIME_OPS*);
(*** ANI_CLASS: ***)
(**)
(*** ANI ==> ASSEMBLE_NEXT_INSTRUCTION ***)
begin (*ASMNXTINST*)
if JUMPTABLE_IN_PROGRESS then
JUMPTABLE_IN_PROGRESS :=
(OPC=UUJP) or (OPC=ULAB) or (OPC=UDEF) or (OPC=ULOC)
or (OPC=UBGN)
else
JUMPTABLE_IN_PROGRESS := false;
(*Some operations are available as both instructions and
as standard procedures. Translate such into either one or the
other to avoid duplication of effort.*)
(* Requires PASCAL-UCode compilers to emit CSP NEW/DSP!!!*)
%
if (OPC = UNEW) or (OPC = UDSP) then
begin
NAM1.LEN := 3;
if OPC = UDSP then
begin
NAM1.NAM := 'DSP '
end (*if OPC = UDSP*)
else if OPC = UNEW then
begin
NAM1.NAM := 'NEW ';
PUSHTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUJ;
FPA.MEMADR.DSPLMT := I1;
end;
OPC := UCSP;
end (*if OPC = UNEW*)
end (*if (OPC = ...*); \
case OPC of
UABS, UNEG, UADD, UINC, UDEC : ARITH_1_OPS;
USUB : ARITH_2_OPS;
UMPY, USQR : ARITH_3_OPS;
UDIV, UDMD, UMOD : ARITH_4_OPS;
UEQU, UGEQ, UGRT, ULEQ, ULES,
UNEQ, UIEQU,UIGEQ,UIGRT,UILEQ,
UILES,UINEQ : REL_OPS;
UAND, UIOR, UXOR, UNOT, UODD : BOOL_OPS;
UDIF, UINT, UUNI, UINN, USGS,
UADJ, UMUS : SET_OPS;
ULCA, ULDA, ULDC, ULOD, ULDP,UILOD,
UPLOD : LOAD1_STORE_OPS;
USTR,UNSTR,UISTR,UINST,UPSTR, UMOV :
LOAD2_STORE_OPS;
UFJP, UTJP, UUJP, UXJP,UGOOB,
ULAB,UCLAB : FLOW_CONTROL_OPS;
UBGN, UEND, USTP, UENT,UBGNB,
UENDB : ENVIRONMENT_OPS;
UCHKL,UCHKH,UCHKT,UCHKF,UCHKN : CHECK_OPS;
URND, UTYP, UTYP2, UCVT,UCVT2 : TYPE_CONV_OPS;
UDUP, USWP, UIXA : VIRT_STK_OPS;
UMST, UPAR, UCUP,UICUP, UCSP,
URET : PROC_CALL_OPS;
UIMPP,UIMPV,UEXPP,UEXPV : IMP_EXP_OPS;
UCOMM,UOPTN, ULEX, USYM,ULIVE,
UDEAD, UDOA, UDEF,UMDEF, ULOC : COMP_TIME_OPS;
UNEW, UDSP : ERROR(WNOT_IMPLEMENTED);
end (*case OPC of*);
end (*ASMNXTINST*);
(** READNXTINST_CLASS: READNXTINST READNAM READTYP READMTYP READINT READREAL READSTRING READSET UUNK *)
(**)
procedure READNXTINST;
(*Read next P-Code instruction and convert it to internal form.*)
var CH : char;
procedure READNAM (var NAM : NAMEREC);
(*Skip initial blanks and commas and read a
label or procedure identifier into NAM.*)
var I : 0..ALFASIZE;
CH : char;
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
NAM.NAM := ' ';
I := 0;
repeat
I := I + 1;
READ (INPUT, CH);
NAM.NAM[I] := CH
until (I=ALFASIZE) or (INPUT↑=' ') or (INPUT↑=',');
while (INPUT↑<>' ') and (INPUT↑<>',') do
get (INPUT);
NAM.LEN := I;
end (*READNAM*);
procedure READTYP (var TYP : OPNDTYPE);
(*Skip initial blanks and commas and read a
type character. Translate it into an
OPNDTYPE and return it in TYP.*)
var CH : char;
begin
repeat
READ (INPUT, CH)
until (CH <> ' ') and (CH <> ',');
TYP := FIRSTTYPE;
while (TYP < LASTTYPE) and (TYPECODE[TYP] <> CH) do
TYP := succ(TYP);
if TYPECODE[TYP] <> CH then
ERROR (WINVAL_U_TYPECODE);
end (*READTYP*);
procedure READMTYP (var TYP : MEMTYPE);
(*Skip initial blanks and commas and read a
type character. Translate it into a
MEMTYPE and return it in TYP.*)
var CH : char;
begin
repeat
READ (INPUT, CH)
until (CH <> ' ') and (CH <> ',');
TYP := FIRSTMTYPE;
while (TYP < LASTMTYPE) and (MTYPECODE[TYP] <> CH) do
TYP := succ(TYP);
if MTYPECODE[TYP] <> CH then
ERROR (WINVALID_MEMORY_TYPE);
end (*READTYP*);
procedure READINT (var I : integer);
(*Skip initial blanks and commas and read an
integer into I.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, I);;
end (*READINT*);
procedure READREAL (var R : real);
(*Skip initial blanks and commas and read a
real number into R.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, R);;
end (*READREAL*);
(* Comment out the 370 version...
procedure READSET(var S : SETREP);
%*Read an input-format set and convert it to a SETREP,
returning it in S. This procedure changes when
sets get bigger for the real machine.*\
var SETINT :
record
DUMMY : integer; %*alignment (not needed?)*\
case BIT of
0 : (S : SETREP);
1 : (I : array[1..2] of integer)
end %*SETINT*\;
INT1, INT2 : integer;
begin
while INPUT↑ <> '(' do get(INPUT);
get(INPUT);
READINT(INT1);
READINT(INT2);
SETINT.I[1] := INT1*TWOEXP[16] + INT2;
READINT(INT1);
READINT(INT2);
SETINT.I[2] := INT1*TWOEXP[16] + INT2;
S := SETINT.S
end %*READSET*\;
...*)
procedure READSET(var S : SETREP);
(*Read an input-format set and convert it to a SETREP,
returning it in S. PDP-10 version. *)
var I, J, N : integer;
INTS : array[1..NUMOFSETOPND] of integer;
begin
while INPUT↑ <> '(' do get(INPUT);
get(INPUT);
for I := 1 to NUMOFSETOPND do READINT(INTS[I]);
S := NULL_SET; (*setch*)
N := 0;
for I := NUMOFSETOPND downto 1 do
for J := 1 to 16 do
begin
if odd(INTS[I]) then BUILD_SET(S,N); (*setch*)
INTS[I] := INTS[I] div 2;
N := N + 1
end
end (*READSET*);
procedure READSTRING(var STRVAL : STRINGTYPE; var STRLGTH : STRINX);
(*Read a string into STRVAL -- als/peg 24jul7.*)
var CH : char;
begin
WHILE (CH <> '''') and not eoln (INPUT) do READ (CH);
READ (CH);
STRLGTH := 0;
while (CH<>'''') or (INPUT↑='''') do
begin
STRLGTH := STRLGTH + 1;
SVAL[STRLGTH] := CH;
if CH = '''' then READ (CH);
READ (CH);
end (*while*);
end (*READSTRING*);
begin (*READNXTINST*)
if INPUT↑ <> ' ' then READNAM (NAM0);
repeat get(INPUT) until INPUT↑ <> ' ';
READ(CH); MNEM[1] := CH;
READ(CH); MNEM[2] := CH;
READ(CH); MNEM[3] := CH;
if INPUT↑ = ' ' then CH := ' ' else READ(CH);
MNEM[4] := CH;
OPC := MNEM_TO_OPC(MNEM);
case OPC of
UCHKF, UCHKN, UCHKT, URET :
(*null case*);
UCLAB, ULAB, UMST, UNEW, UPLEX, UTJP :
READINT (I1);
UGOOB, UEXPP, UIMPP, UIMPV :
begin
READINT (I1);
READNAM (NAM1);
end;
ULEX : begin
READINT (I1);
READINT (I2);
end;
ULDP : begin
READINT (I1);
READINT (I2);
READNAM (NAM1);
end;
ULOC : begin
READINT (I1);
READINT (I2);
READINT (I3);
READINT (I4);
end;
UEND : READNAM (NAM1);
UBGN, UFJP, UUJP, USTP :
READNAM (NAM1);
UOPTN : begin
READNAM (NAM1);
READINT (I1);
if (NAM1.NAM[1] = 'P') and (NAM1.NAM[6] = 'H') then
READINT (I2);
end;
UABS, UADD, USUB, UMPY, UDIV, UAND, UDIF, UDMD, UDSP, UDUP,
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, UIEQU,UINEQ,UIGEQ,UIGRT,
UILEQ,UILES,UINN, UINT, UIOR, UMOD, UMUS, UNEG, UNOT, UODD,
USDEF,USGS, USQR, UUNI :
READTYP (TYP);
UCVT, UCVT2, URND, USWP, UTYP, UTYP2 :
begin
READTYP (TYP);
READTYP (TYPO2);
end;
UDEC, UINC, UIXA, UMOV :
begin
READTYP (TYP);
READINT (I1);
end;
UCHKL, UCHKH :
begin
READTYP (TYP);
if TYP = TYPUC then
READSTRING(SVAL, SLGTH)
else READINT (I1);
end;
UADJ, UICUP, UILOD, UINST, UISTR:
begin
READTYP (TYP);
READINT (I1);
READINT (I2);
end;
UENT : begin
READTYP (TYP);
READINT (I1);
READINT (I2);
READINT (I3);
READINT (I4);
end;
UDEF : begin
READMTYP (MTYP);
READINT (I1);
end;
UDEAD, UDOA, UEXPV, ULDA, ULIVE, USYM :
begin
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
end;
UMDEF : begin
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
while (CH = ' ') and not eoln(INPUT) do READ(CH);
SLGTH := 0;
while (SLGTH < STRINGMAX) and not eoln(INPUT) do
begin
READ (CH);
SLGTH := SLGTH + 1;
SVAL[SLGTH] := CH;
end (*while*);
end;
UXJP :
begin
READTYP (TYP);
READNAM (NAM1);
READNAM (NAM2);
READINT (I1);
READINT (I2);
end;
ULOD, UNSTR, UPAR, UPLOD, UPSTR, USTR :
begin
READTYP (TYP);
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
end;
UCSP : begin
READTYP (TYP);
READNAM (NAM1);
READINT (I1);
READINT (I2);
end;
UCUP : begin
READTYP (TYP);
READINT (I1);
READNAM (NAM1);
READINT (I2);
READINT (I3);
end;
ULDC : begin
READTYP (TYP);
READINT (I1);
case TYP of
TYPUI, TYPUK, TYPUM, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
READINT (I2);
TYPUC : READSTRING (SVAL, SLGTH);
TYPUR : READREAL (R1);
TYPUN : (*null case*);
TYPUS : READSET (P1);
end (*case TYP of*);
end (*ULDC*);
ULCA : begin
READTYP (TYP);
READINT (I1);
case TYP of
TYPUI, TYPUK, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
READINT (I2);
TYPUC : READSTRING (SVAL, SLGTH);
TYPUR : READREAL (R1);
TYPUS : READSET (P1);
TYPUM : READSTRING (SVAL, SLGTH);
end (*case TYP of*);
end (*ULCA*);
UCOMM :
begin
(* while (CH = ' ') and not eoln(INPUT) do READ(CH);*)
(**** this needs to be fixed *)
READSTRING (SVAL, SLGTH);
end (*ucomm*);
UUNK : begin
READINT (I2);
READINT (I3);
while (CH = ' ') and not eoln(INPUT) do READ(CH);
(* READSTRING (SVAL, SLGTH); *)
end;
end (*case OPC of*);
READLN(INPUT);
end (*READNXTINST*);
(** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
(**)
procedure INITIALIZE;
var
I, N : integer;
T, T1, T2 : OPNDTYPE;
S1OP : S1OPCODE;
procedure ENTER_OPC (NAM : CHAR4; OPC : U_OPCODE); (*ALS*)
var H : 0..OPCHTSIZEM1;
begin
H := OPC_HASH(NAM);
while OPCHASHTAB[H].OPCNAM <> ' ' do
H := (H + 1) mod OPCHTSIZE;
OPCHASHTAB[H].OPCNAM := NAM;
OPCHASHTAB[H].OPC := OPC;
end (*ENTER_OPC*);
procedure ENTER_CSP (NAM : CHAR3; CSP : P_STANDARDPROC);
var H : 0..CSPHTSIZEM1;
NAMALFA : ALFA;
begin
NAMALFA := ' ';
NAMALFA[1]:=NAM[1]; NAMALFA[2]:=NAM[2]; NAMALFA[3]:=NAM[3];
H := CSP_HASH(NAMALFA);
while CSPHASHTAB[H].CSPNAM.NAM <> ' ' do
H := (H + 1) mod CSPHTSIZE;
CSPHASHTAB[H].CSPNAM.NAM := NAMALFA;
CSPHASHTAB[H].CSPNAM.LEN := 3;
CSPHASHTAB[H].CSP := CSP;
end (*ENTER_CSP*);
procedure INIT1;
begin
for I := 0 to SETREP_MAX DO (*setch*) (*X10S1*)
NULL_SET[I] := [ ]; (*setch*) (*X10S1*)
(* NULL_SET := [ ]; *) (*setch*) (*X10S1*)
for I := MINBLOCK to MAXBLOCK do
BLOCKTABLE[I] := ILLBLOCKNO;
ZEROS1WORD.LHALF := 0; ZEROS1WORD.RHALF := 0;
with EMPTY_OP do
begin
X := 0;
REG := 0; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_EV; XW.P := 0;
XW.V := 0; XW.D := 0;
XW.I := 0; XW.S := 0;
XW.ADDR := 0; XW.REG := 0;
XW.DISP := 0;
end (*EMPTY_OP*);
with ZERO_OP do
begin
X := 0;
REG := 1; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*ZERO_OP*);
with EXTENDED_ZERO_OP do
begin
X := 1;
REG := 1; F := 1;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*EXTENDED_ZERO_OP*);
with EMPTYCODELIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYCODELIST*);
with EMPTYJUMPLIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYJUMPLIST*);
with ZEROFPA do
begin
WHICH := MEM;
MEMADR.LVL := 0; MEMADR.DSPLMT := 0;
end (*ZEROFPA*);
with ZEROVPA do
begin
VSHIFT := 0; VPAIND := IND1;
VPA.WHICH := MEM;
VPA.MEMADR.LVL := 0;
VPA.MEMADR.DSPLMT := 0;
end (*ZEROVPA*);
with ZERODATUM do
begin
CODESTART := nil;
DTYPE := TYPUP; (*no legal datum should be*)
DLENGTH := 0;
MTYPE := NON_SPACE;
BREPRES := BINTVAL;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BFALLTHRUSKIPLOC := nil;
BJUMPON := false;
SCNST := NULL_SET; RCNST := 0.0; (*setch*)
FINALIND := IND0; FPA := ZEROFPA;
NVPAS := 0;
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
end (*ZERODATUM*);
with CURPROCSPEC do (* peg 18jul79...*)
begin (*Set up dummy entry*)
PROCTYPE := TYPUP;
PROCNAM.NAM := 'DUMMY ';
PROCNAM.LEN := 5;
REGPARMAREA := 0;
R_MEMORY_AREA := MIN_ON_COMP_MACH;
M_MEMORY_AREA := MIN_ON_COMP_MACH;
end (*CURPROCSPEC*); (*...peg 18jul79 *)
REG_OPERAND (UNUSED_OP, S1R0); (*unused operands must specify R0*)
REG_OPERAND (OPNDRTB, S1RTB);
REG_OPERAND (OPNDRSP, S1RSP);
SEG_EP_RELPC := SEG_START_RELPC + SEG_EP_DISP;
FIRSTTYPE := ILLARITH; LASTTYPE := TYPUS;
FIRSTMTYPE := NON_SPACE; LASTMTYPE := M_SPACE;
DEFAULTMTYPE := M_SPACE;
FIRSTS1OP := XILLEGAL; LASTS1OP := XXOR_Q;
TWOEXP[0] := 1;
for I := 1 to MAX_EXP_ON_COMP_MACH do TWOEXP[I] := 2 * TWOEXP[I-1];
MAXTMPS1REG := MINPARS1REG - 1;
MINDSPS1REG := MAXDSPS1REG + 1;
JUMPTABLE_IN_PROGRESS := false;
MTYPECODE[NON_SPACE] := ' ';
MTYPECODE[R_SPACE] := 'R';
MTYPECODE[M_SPACE] := 'M';
TYPECODE[TYPUA] := 'A'; (*address*)
TYPECODE[TYPUB] := 'B'; (*boolean*)
TYPECODE[TYPUC] := 'C'; (*character*)
TYPECODE[TYPUE] := 'E'; (*entry point of proc. as parameter*)
TYPECODE[TYPUI] := 'I'; (*double-word integer*)
TYPECODE[TYPUJ] := 'J'; (*single-word integer*)
TYPECODE[TYPUK] := 'K'; (*double-word non-neg. integer*)
TYPECODE[TYPUL] := 'L'; (*single-word non-neg. integer*)
TYPECODE[TYPUM] := 'M'; (*record, array*)
TYPECODE[TYPUN] := 'N'; (*nil pointer*)
TYPECODE[TYPUP] := 'P'; (*procedure*)
TYPECODE[TYPUQ] := 'Q'; (*double-word real*)
TYPECODE[TYPUR] := 'R'; (*single-word real*)
TYPECODE[TYPUS] := 'S'; (*set*)
ALIGNBNDRY[TYPUA] := WORDUNITS;
ALIGNBNDRY[TYPUB] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPUC] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPUE] := WORDUNITS;
ALIGNBNDRY[TYPUI] := WORDUNITS;
ALIGNBNDRY[TYPUJ] := WORDUNITS;
ALIGNBNDRY[TYPUK] := WORDUNITS;
ALIGNBNDRY[TYPUL] := WORDUNITS;
ALIGNBNDRY[TYPUM] := WORDUNITS;
ALIGNBNDRY[TYPUN] := WORDUNITS;
ALIGNBNDRY[TYPUP] := 0;
ALIGNBNDRY[TYPUQ] := WORDUNITS;
ALIGNBNDRY[TYPUR] := WORDUNITS;
ALIGNBNDRY[TYPUS] := WORDUNITS;
ALIGNBNDRY[TYPH] := HALFWORDUNITS;
ALIGNBNDRY[TYPQ] := QUARTERWORDUNITS;
S1SIZE[TYPUA] := S1S; S1SIZE[TYPUM] := S1S;
S1SIZE[TYPUB] := S1Q; S1SIZE[TYPUN] := S1S;
S1SIZE[TYPUC] := S1Q; S1SIZE[TYPUP] := S1S;
S1SIZE[TYPUI] := S1D; S1SIZE[TYPQ] := S1Q;
S1SIZE[TYPH] := S1H; S1SIZE[TYPUR] := S1S;
S1SIZE[TYPUJ] := S1S; S1SIZE[TYPUS] := S1D;
S1SIZE[TYPUQ] := S1D;
FUNCUNITS[TYPUA] := WORDUNITS;
FUNCUNITS[TYPUB] := WORDUNITS;
FUNCUNITS[TYPUC] := WORDUNITS;
FUNCUNITS[TYPUI] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUJ] := WORDUNITS;
FUNCUNITS[TYPUK] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUL] := WORDUNITS;
FUNCUNITS[TYPUM] := WORDUNITS;
FUNCUNITS[TYPUN] := WORDUNITS;
FUNCUNITS[TYPUP] := 0;
FUNCUNITS[TYPUQ] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUR] := WORDUNITS;
FUNCUNITS[TYPUS] := 0; (*setch*)
FUNCUNITS[TYPH] := WORDUNITS;
FUNCUNITS[TYPQ] := WORDUNITS;
for T := FIRSTTYPE to LASTTYPE do
begin
IS_DOUBLE[T] := (T in [TYPUI, TYPUK, TYPUQ, TYPUS]);(*setch*)
IS_SINGLE[T] := (T in [TYPUA, TYPUJ, TYPUL, TYPUM, TYPUN, TYPUR]);
IS_INTEGER[T] := (T in [TYPQ, TYPH, TYPUI, TYPUJ, TYPUK, TYPUL]);
IS_REAL[T] := (T in [TYPUQ, TYPUR]);
IS_SIGNED_NUM[T] := (T in [TYPUI, TYPUJ, TYPUQ, TYPUR]);
end (*for T*);
SKP_NON_X[TYPUA] := XILLEGAL; SKP_NON_X[TYPUM] := XILLEGAL;
SKP_NON_X[TYPUB] := XSKP_NON_Q; SKP_NON_X[TYPUN] := XILLEGAL;
SKP_NON_X[TYPUC] := XSKP_NON_Q; SKP_NON_X[TYPUP] := XILLEGAL;
SKP_NON_X[TYPUI] := XSKP_NON_D; SKP_NON_X[TYPQ] := XSKP_NON_Q;
SKP_NON_X[TYPH] := XSKP_NON_H; SKP_NON_X[TYPUR] := XILLEGAL;
SKP_NON_X[TYPUJ] := XSKP_NON_S; SKP_NON_X[TYPUS] := XILLEGAL;
SKP_NON_X[TYPUQ] := XILLEGAL;
MOVMQ_N[1] := XMOV_Q_Q; MOVMQ_N[2] := XMOVMQ_2;
MOVMQ_N[3] := XMOVMQ_3; MOVMQ_N[4] := XMOVMQ_4;
MOVMQ_N[5] := XMOVMQ_5; MOVMQ_N[6] := XMOVMQ_6;
MOVMQ_N[7] := XMOVMQ_7; MOVMQ_N[8] := XMOVMQ_8;
MOVMQ_N[9] := XMOVMQ_9; MOVMQ_N[10] := XMOVMQ_10;
MOVMQ_N[11] := XMOVMQ_11; MOVMQ_N[12] := XMOVMQ_12;
MOVMQ_N[13] := XMOVMQ_13; MOVMQ_N[14] := XMOVMQ_14;
MOVMQ_N[15] := XMOVMQ_15; MOVMQ_N[16] := XMOVMQ_16;
MOVMQ_N[17] := XMOVMQ_17; MOVMQ_N[18] := XMOVMQ_18;
MOVMQ_N[19] := XMOVMQ_19; MOVMQ_N[20] := XMOVMQ_20;
MOVMQ_N[21] := XMOVMQ_21; MOVMQ_N[22] := XMOVMQ_22;
MOVMQ_N[23] := XMOVMQ_23; MOVMQ_N[24] := XMOVMQ_24;
MOVMQ_N[25] := XMOVMQ_25; MOVMQ_N[26] := XMOVMQ_26;
MOVMQ_N[27] := XMOVMQ_27; MOVMQ_N[28] := XMOVMQ_28;
MOVMQ_N[29] := XMOVMQ_29; MOVMQ_N[30] := XMOVMQ_30;
MOVMQ_N[31] := XMOVMQ_31; MOVMQ_N[32] := XMOVMQ_32;
MOVMS_N[1] := XMOV_S_S; MOVMS_N[2] := XMOVMS_2; (*ALS*)
MOVMS_N[3] := XMOVMS_3; MOVMS_N[4] := XMOVMS_4;
MOVMS_N[5] := XMOVMS_5; MOVMS_N[6] := XMOVMS_6;
MOVMS_N[7] := XMOVMS_7; MOVMS_N[8] := XMOVMS_8;
MOVMS_N[9] := XMOVMS_9; MOVMS_N[10] := XMOVMS_10;
MOVMS_N[11] := XMOVMS_11; MOVMS_N[12] := XMOVMS_12;
MOVMS_N[13] := XMOVMS_13; MOVMS_N[14] := XMOVMS_14;
MOVMS_N[15] := XMOVMS_15; MOVMS_N[16] := XMOVMS_16;
MOVMS_N[17] := XMOVMS_17; MOVMS_N[18] := XMOVMS_18;
MOVMS_N[19] := XMOVMS_19; MOVMS_N[20] := XMOVMS_20;
MOVMS_N[21] := XMOVMS_21; MOVMS_N[22] := XMOVMS_22;
MOVMS_N[23] := XMOVMS_23; MOVMS_N[24] := XMOVMS_24;
MOVMS_N[25] := XMOVMS_25; MOVMS_N[26] := XMOVMS_26;
MOVMS_N[27] := XMOVMS_27; MOVMS_N[28] := XMOVMS_28;
MOVMS_N[29] := XMOVMS_29; MOVMS_N[30] := XMOVMS_30;
MOVMS_N[31] := XMOVMS_31; MOVMS_N[32] := XMOVMS_32; (*ALS*)
MOV_X_X[TYPUA] := XMOV_S_S; MOV_X_X[TYPUM] := XMOV_S_S;
MOV_X_X[TYPUB] := XMOV_Q_Q; MOV_X_X[TYPUN] := XMOV_S_S;
MOV_X_X[TYPUC] := XMOV_Q_Q; MOV_X_X[TYPUP] := XILLEGAL;
MOV_X_X[TYPUI] := XMOV_D_D; MOV_X_X[TYPQ] := XMOV_Q_Q;
MOV_X_X[TYPH] := XMOV_H_H; MOV_X_X[TYPUR] := XMOV_S_S;
MOV_X_X[TYPUJ] := XMOV_S_S;
MOV_X_X[TYPUS] := MOVMS_N[NUMOFSETPARTS*2]; (*setch*)
MOV_X_X[TYPUQ] := XMOV_D_D;
ABS_X[TYPUA] := XILLEGAL; ABS_X[TYPUM] := XILLEGAL;
ABS_X[TYPUB] := XILLEGAL; ABS_X[TYPUN] := XILLEGAL;
ABS_X[TYPUC] := XILLEGAL; ABS_X[TYPUP] := XILLEGAL;
ABS_X[TYPUI] := XABS_D; ABS_X[TYPQ] := XABS_Q;
ABS_X[TYPH] := XABS_H; ABS_X[TYPUR] := XABS_S;
ABS_X[TYPUJ] := XABS_S; ABS_X[TYPUS] := XILLEGAL;
ABS_X[TYPUQ] := XABS_D;
NEG_X[TYPUA] := XILLEGAL; NEG_X[TYPUM] := XILLEGAL;
NEG_X[TYPUB] := XILLEGAL; NEG_X[TYPUN] := XILLEGAL;
NEG_X[TYPUC] := XILLEGAL; NEG_X[TYPUP] := XILLEGAL;
NEG_X[TYPUI] := XNEG_D; NEG_X[TYPQ] := XNEG_Q;
NEG_X[TYPH] := XNEG_H; NEG_X[TYPUR] := XNEG_S;
NEG_X[TYPUJ] := XNEG_S; NEG_X[TYPUS] := XILLEGAL;
NEG_X[TYPUQ] := XNEG_D;
FLOAT_S_X[TYPUA] := XILLEGAL;
FLOAT_S_X[TYPUB] := XILLEGAL;
FLOAT_S_X[TYPUC] := XILLEGAL;
FLOAT_S_X[TYPUI] := XFLOAT_S_D;
FLOAT_S_X[TYPH] := XFLOAT_S_H;
FLOAT_S_X[TYPUJ] := XFLOAT_S_S;
FLOAT_S_X[TYPUM] := XILLEGAL;
FLOAT_S_X[TYPUN] := XILLEGAL;
FLOAT_S_X[TYPUP] := XILLEGAL;
FLOAT_S_X[TYPQ] := XFLOAT_S_Q;
FLOAT_S_X[TYPUR] := XILLEGAL;
FLOAT_S_X[TYPUS] := XILLEGAL;
FLOAT_S_X[TYPUQ] := XILLEGAL;
SLR_N[0] := XSLR_0; SLR_N[1] := XSLR_1;
SLR_N[2] := XSLR_2; SLR_N[3] := XSLR_3;
SLR_N[4] := XSLR_4; SLR_N[5] := XSLR_5;
SLR_N[6] := XSLR_6; SLR_N[7] := XSLR_7;
SLR_N[8] := XSLR_8; SLR_N[9] := XSLR_9;
SLR_N[10] := XSLR_10; SLR_N[11] := XSLR_11;
SLR_N[12] := XSLR_12; SLR_N[13] := XSLR_13;
SLR_N[14] := XSLR_14; SLR_N[15] := XSLR_15;
SLR_N[16] := XSLR_16; SLR_N[17] := XSLR_17;
SLR_N[18] := XSLR_18; SLR_N[19] := XSLR_19;
SLR_N[20] := XSLR_20; SLR_N[21] := XSLR_21;
SLR_N[22] := XSLR_22; SLR_N[23] := XSLR_23;
SLR_N[24] := XSLR_24; SLR_N[25] := XSLR_25;
SLR_N[26] := XSLR_26; SLR_N[27] := XSLR_27;
SLR_N[28] := XSLR_28; SLR_N[29] := XSLR_29;
SLR_N[30] := XSLR_30; SLR_N[31] := XSLR_31;
SLRADR_N[0] := XSLRADR_0; SLRADR_N[1] := XSLRADR_1;
SLRADR_N[2] := XSLRADR_2; SLRADR_N[3] := XSLRADR_3;
SLRADR_N[4] := XSLRADR_4; SLRADR_N[5] := XSLRADR_5;
SLRADR_N[6] := XSLRADR_6; SLRADR_N[7] := XSLRADR_7;
SLRADR_N[8] := XSLRADR_8; SLRADR_N[9] := XSLRADR_9;
SLRADR_N[10] := XSLRADR_10; SLRADR_N[11] := XSLRADR_11;
SLRADR_N[12] := XSLRADR_12; SLRADR_N[13] := XSLRADR_13;
SLRADR_N[14] := XSLRADR_14; SLRADR_N[15] := XSLRADR_15;
SLRADR_N[16] := XSLRADR_16; SLRADR_N[17] := XSLRADR_17;
SLRADR_N[18] := XSLRADR_18; SLRADR_N[19] := XSLRADR_19;
SLRADR_N[20] := XSLRADR_20; SLRADR_N[21] := XSLRADR_21;
SLRADR_N[22] := XSLRADR_22; SLRADR_N[23] := XSLRADR_23;
SLRADR_N[24] := XSLRADR_24; SLRADR_N[25] := XSLRADR_25;
SLRADR_N[26] := XSLRADR_26; SLRADR_N[27] := XSLRADR_27;
SLRADR_N[28] := XSLRADR_28; SLRADR_N[29] := XSLRADR_29;
SLRADR_N[30] := XSLRADR_30; SLRADR_N[31] := XSLRADR_31;
BTRP_B_X[TYPUA] := XBTRP_B_S; BTRP_B_X[TYPUM] := XBTRP_B_S;
BTRP_B_X[TYPUB] := XBTRP_B_Q; BTRP_B_X[TYPUN] := XILLEGAL;
BTRP_B_X[TYPUC] := XBTRP_B_Q; BTRP_B_X[TYPUP] := XILLEGAL;
BTRP_B_X[TYPUI] := XBTRP_B_D; BTRP_B_X[TYPQ] := XBTRP_B_Q;
BTRP_B_X[TYPH] := XBTRP_B_H; BTRP_B_X[TYPUR] := XILLEGAL;
BTRP_B_X[TYPUJ] := XBTRP_B_S; BTRP_B_X[TYPUS] := XILLEGAL;
BTRP_B_X[TYPUQ] := XILLEGAL;
BTRP_N_X[0,TYPUA] := XBTRP_0_S;
BTRP_N_X[0,TYPUB] := XBTRP_0_Q;
BTRP_N_X[0,TYPUC] := XBTRP_0_Q;
BTRP_N_X[0,TYPUI] := XBTRP_0_D;
BTRP_N_X[0,TYPH] := XBTRP_0_H;
BTRP_N_X[0,TYPUJ] := XBTRP_0_S;
BTRP_N_X[0,TYPUM] := XBTRP_0_S;
BTRP_N_X[0,TYPUN] := XILLEGAL;
BTRP_N_X[0,TYPUP] := XILLEGAL;
BTRP_N_X[0,TYPQ] := XBTRP_0_Q;
BTRP_N_X[0,TYPUR] := XILLEGAL;
BTRP_N_X[0,TYPUS] := XILLEGAL;
BTRP_N_X[0,TYPUQ] := XILLEGAL;
BTRP_N_X[1,TYPUA] := XBTRP_1_S;
BTRP_N_X[1,TYPUB] := XBTRP_1_Q;
BTRP_N_X[1,TYPUC] := XBTRP_1_Q;
BTRP_N_X[1,TYPUI] := XBTRP_1_D;
BTRP_N_X[1,TYPH] := XBTRP_1_H;
BTRP_N_X[1,TYPUJ] := XBTRP_1_S;
BTRP_N_X[1,TYPUM] := XBTRP_1_S;
BTRP_N_X[1,TYPUN] := XILLEGAL;
BTRP_N_X[1,TYPUP] := XILLEGAL;
BTRP_N_X[1,TYPQ] := XBTRP_1_Q;
BTRP_N_X[1,TYPUR] := XILLEGAL;
BTRP_N_X[1,TYPUS] := XILLEGAL;
BTRP_N_X[1,TYPUQ] := XILLEGAL;
end (*INIT1*);
(** INITIALIZE_CLASS: INIT2 **)
(**)
procedure INIT2;
begin
for T1 := FIRSTTYPE to LASTTYPE do
for T2 := FIRSTTYPE to LASTTYPE do
begin
MOV_X_Y[T1, T2] := XILLEGAL;
ARITH_RESULT_TYPE[T1, T2] := ILLARITH;
COMPARE_COERCE_TYPE[T1, T2] := ILLCOMP;
end (*for*);
MOV_X_Y [TYPUA, TYPUA] := XMOV_S_S;
MOV_X_Y [TYPUA, TYPUN] := XMOV_S_S;
MOV_X_Y [TYPUA, TYPUM] := XMOV_S_S;
MOV_X_Y [TYPUB, TYPUB] := XMOV_Q_Q;
MOV_X_Y [TYPUC, TYPUC] := XMOV_Q_Q;
MOV_X_Y [TYPQ, TYPQ] := XMOV_Q_Q;
MOV_X_Y [TYPQ, TYPH] := XTRANS_Q_H;
MOV_X_Y [TYPQ, TYPUI] := XTRANS_Q_D;
MOV_X_Y [TYPQ, TYPUJ] := XTRANS_Q_S;
MOV_X_Y [TYPQ, TYPUK] := XTRANS_Q_D;
MOV_X_Y [TYPQ, TYPUL] := XTRANS_Q_S;
MOV_X_Y [TYPH, TYPQ] := XTRANS_H_Q;
MOV_X_Y [TYPH, TYPH] := XMOV_H_H;
MOV_X_Y [TYPH, TYPUI] := XTRANS_H_D;
MOV_X_Y [TYPH, TYPUJ] := XTRANS_H_S;
MOV_X_Y [TYPH, TYPUK] := XTRANS_H_D;
MOV_X_Y [TYPH, TYPUL] := XTRANS_H_S;
MOV_X_Y [TYPUI, TYPQ] := XTRANS_D_Q;
MOV_X_Y [TYPUI, TYPH] := XTRANS_D_H;
MOV_X_Y [TYPUI, TYPUI] := XMOV_D_D;
MOV_X_Y [TYPUI, TYPUJ] := XTRANS_D_S;
MOV_X_Y [TYPUI, TYPUK] := XMOV_D_D;
MOV_X_Y [TYPUI, TYPUL] := XTRANS_D_S;
MOV_X_Y [TYPUJ, TYPQ] := XTRANS_S_Q;
MOV_X_Y [TYPUJ, TYPH] := XTRANS_S_H;
MOV_X_Y [TYPUJ, TYPUI] := XTRANS_S_D;
MOV_X_Y [TYPUJ, TYPUJ] := XMOV_S_S;
MOV_X_Y [TYPUJ, TYPUK] := XTRANS_S_D;
MOV_X_Y [TYPUJ, TYPUL] := XMOV_S_S;
MOV_X_Y [TYPUJ, TYPUR] := XFX_DM_S_S;
MOV_X_Y [TYPUK, TYPQ] := XTRANS_D_Q;
MOV_X_Y [TYPUK, TYPH] := XTRANS_D_H;
MOV_X_Y [TYPUK, TYPUI] := XMOV_D_D;
MOV_X_Y [TYPUK, TYPUJ] := XTRANS_D_S;
MOV_X_Y [TYPUK, TYPUK] := XMOV_D_D;
MOV_X_Y [TYPUK, TYPUL] := XTRANS_D_S;
MOV_X_Y [TYPUL, TYPQ] := XTRANS_S_Q;
MOV_X_Y [TYPUL, TYPH] := XTRANS_S_H;
MOV_X_Y [TYPUL, TYPUI] := XTRANS_S_D;
MOV_X_Y [TYPUL, TYPUJ] := XMOV_S_S;
MOV_X_Y [TYPUL, TYPUK] := XTRANS_S_D;
MOV_X_Y [TYPUL, TYPUL] := XMOV_S_S;
MOV_X_Y [TYPUL, TYPUR] := XFX_DM_S_S;
MOV_X_Y [TYPUQ, TYPUQ] := XMOV_D_D;
MOV_X_Y [TYPUQ, TYPUR] := XFTRANS_D_S;
MOV_X_Y [TYPUR, TYPUI] := XFLOAT_S_D;
MOV_X_Y [TYPUR, TYPUJ] := XFLOAT_S_S;
MOV_X_Y [TYPUR, TYPUK] := XFLOAT_S_D;
MOV_X_Y [TYPUR, TYPUL] := XFLOAT_S_S;
MOV_X_Y [TYPUR, TYPUQ] := XFTRANS_S_D;
MOV_X_Y [TYPUR, TYPUR] := XMOV_S_S;
MOV_X_Y [TYPUS, TYPUS] := MOVMS_N[NUMOFSETPARTS*2]; (*setch*)
for T1 := TYPQ to TYPUJ do
for T2 := TYPQ to TYPUJ do
ARITH_RESULT_TYPE[T1,T2] := TYPUJ;
for T := TYPQ to TYPUI do
begin
ARITH_RESULT_TYPE[T,TYPUI] := TYPUI;
ARITH_RESULT_TYPE[TYPUI,T] := TYPUI;
end;
ARITH_RESULT_TYPE [TYPUQ,TYPUQ] := TYPUQ;
ARITH_RESULT_TYPE [TYPUQ,TYPUR] := TYPUQ;
ARITH_RESULT_TYPE [TYPUR,TYPUQ] := TYPUQ;
ARITH_RESULT_TYPE [TYPUR,TYPUR] := TYPUR;
COMPARE_COERCE_TYPE [TYPUA,TYPUM] := TYPUA;
COMPARE_COERCE_TYPE [TYPUM,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUA,TYPUN] := TYPUA;
COMPARE_COERCE_TYPE [TYPUN,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUA,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUQ,TYPUQ] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUR,TYPUQ] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUQ,TYPUR] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUR,TYPUR] := TYPUR;
COMPARE_COERCE_TYPE [TYPQ,TYPQ] := TYPQ;
COMPARE_COERCE_TYPE [TYPQ,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPQ] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPQ,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPH,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPQ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPH] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPQ,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPH,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUJ,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPQ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPH] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUJ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUB,TYPUB] := TYPUB;
COMPARE_COERCE_TYPE [TYPUC,TYPUC] := TYPUC;
COMPARE_COERCE_TYPE [TYPUS,TYPUS] := TYPUS;
REAL_ARITH_OP [S1S, UADD] := XFADD_S;
REAL_ARITH_OP [S1D, UADD] := XFADD_D;
REAL_ARITH_OP [S1S, USUB] := XFSUB_S;
REAL_ARITH_OP [S1D, USUB] := XFSUB_D;
REAL_ARITH_OP [S1S, UMPY] := XFMULT_S;
REAL_ARITH_OP [S1D, UMPY] := XFMULT_D;
REAL_ARITH_OP [S1S, UDIV] := XFDIV_S;
REAL_ARITH_OP [S1D, UDIV] := XFDIV_D;
COMPARE_OP [S1Q, UEQU] := XSKP_EQL_Q;
COMPARE_OP [S1Q, UNEQ] := XSKP_NEQ_Q;
COMPARE_OP [S1Q, UGEQ] := XSKP_GEQ_Q;
COMPARE_OP [S1Q, UGRT] := XSKP_GTR_Q;
COMPARE_OP [S1Q, ULEQ] := XSKP_LEQ_Q;
COMPARE_OP [S1Q, ULES] := XSKP_LSS_Q;
COMPARE_OP [S1H, UEQU] := XSKP_EQL_H;
COMPARE_OP [S1H, UNEQ] := XSKP_NEQ_H;
COMPARE_OP [S1H, UGEQ] := XSKP_GEQ_H;
COMPARE_OP [S1H, UGRT] := XSKP_GTR_H;
COMPARE_OP [S1H, ULEQ] := XSKP_LEQ_H;
COMPARE_OP [S1H, ULES] := XSKP_LSS_H;
COMPARE_OP [S1S, UEQU] := XSKP_EQL_S;
COMPARE_OP [S1S, UNEQ] := XSKP_NEQ_S;
COMPARE_OP [S1S, UGEQ] := XSKP_GEQ_S;
COMPARE_OP [S1S, UGRT] := XSKP_GTR_S;
COMPARE_OP [S1S, ULEQ] := XSKP_LEQ_S;
COMPARE_OP [S1S, ULES] := XSKP_LSS_S;
COMPARE_OP [S1D, UEQU] := XSKP_EQL_D;
COMPARE_OP [S1D, UNEQ] := XSKP_NEQ_D;
COMPARE_OP [S1D, UGEQ] := XSKP_GEQ_D;
COMPARE_OP [S1D, UGRT] := XSKP_GTR_D;
COMPARE_OP [S1D, ULEQ] := XSKP_LEQ_D;
COMPARE_OP [S1D, ULES] := XSKP_LSS_D;
BLKCMP_X_Q [UIEQU] := XBLCMP_EQL_Q;
BLKCMP_X_Q [UINEQ] := XBLCMP_NEQ_Q;
BLKCMP_X_Q [UIGEQ] := XBLCMP_GEQ_Q;
BLKCMP_X_Q [UIGRT] := XBLCMP_GTR_Q;
BLKCMP_X_Q [UILEQ] := XBLCMP_LEQ_Q;
BLKCMP_X_Q [UILES] := XBLCMP_LSS_Q;
for I := 1 to MAXLVL do
LVL_TO_S1REG[I] := MAXDSPS1REG + 1 - I;
for I := 0 to MAXPAREGM1 do
PRM_TO_S1REG[I] := I + MINPARS1REG;
for I := FIRSTS1REG to LASTS1REG do
S1REG_TO_PRM[I] := 1000000;
for I := MINPARS1REG to (MAXPAREGM1+MINPARS1REG) do
S1REG_TO_PRM[I] := I - MINPARS1REG;
ZSEGTYPE_TO_CHARS [ZIS] := 'IS ';
ZSEGTYPE_TO_CHARS [ZDS] := 'DS ';
ZSEGTYPE_TO_CHARS [ZCM] := 'CM ';
ZESDTYPE_TO_CHARS [ZST] := 'ST ';
ZESDTYPE_TO_CHARS [ZIN] := 'IN ';
ZESDTYPE_TO_CHARS [ZDN] := 'DN ';
ZESDTYPE_TO_CHARS [ZAN] := 'AN ';
ZESRTYPE_TO_CHARS [ZIR] := 'IR ';
ZESRTYPE_TO_CHARS [ZDR] := 'DR ';
ZESRTYPE_TO_CHARS [ZAR] := 'AR ';
ZESRTYPE_TO_CHARS [ZXR] := 'XR ';
ZOPR_TO_CHARS [ZPLUS] := '+ ';
ZOPR_TO_CHARS [ZMINUS] := '- ';
ZIXFLAG_TO_CHAR [ZESD] := 'D';
ZIXFLAG_TO_CHAR [ZESR] := 'R';
ZIXFLAG_TO_CHAR [ZSEG] := 'S';
for I := 0 to OPCHTSIZEM1 do
begin
OPCHASHTAB[I].OPCNAM := ' ';
end;
ENTER_OPC ('ABS ', UABS); ENTER_OPC ('ADD ', UADD);
ENTER_OPC ('SUB ', USUB); ENTER_OPC ('MPY ', UMPY);
ENTER_OPC ('DIV ', UDIV); ENTER_OPC ('ADJ ', UADJ);
ENTER_OPC ('AND ', UAND); ENTER_OPC ('BGN ', UBGN);
ENTER_OPC ('BGNB', UBGNB); ENTER_OPC ('CHKF', UCHKF);
ENTER_OPC ('CHKH', UCHKH); ENTER_OPC ('CHKL', UCHKL);
ENTER_OPC ('CHKN', UCHKN); ENTER_OPC ('CHKT', UCHKT);
ENTER_OPC ('CLAB', UCLAB); ENTER_OPC ('COMM', UCOMM);
ENTER_OPC ('CSP ', UCSP); ENTER_OPC ('CUP ', UCUP);
ENTER_OPC ('CVT ', UCVT); ENTER_OPC ('CVT2', UCVT2);
ENTER_OPC ('DEAD', UDEAD); ENTER_OPC ('DEC ', UDEC);
ENTER_OPC ('DEF ', UDEF); ENTER_OPC ('DIF ', UDIF);
ENTER_OPC ('DMD ', UDMD); ENTER_OPC ('DOA ', UDOA);
ENTER_OPC ('DSP ', UDSP); ENTER_OPC ('DUP ', UDUP);
ENTER_OPC ('END ', UEND); ENTER_OPC ('ENDB', UENDB);
ENTER_OPC ('ENT ', UENT); ENTER_OPC ('EXPP', UEXPP);
ENTER_OPC ('EXPV', UEXPV); ENTER_OPC ('FJP ', UFJP);
ENTER_OPC ('ICUP', UICUP); ENTER_OPC ('EQU ', UEQU);
ENTER_OPC ('NEQ ', UNEQ); ENTER_OPC ('GEQ ', UGEQ);
ENTER_OPC ('GOOB', UGOOB);
ENTER_OPC ('GRT ', UGRT); ENTER_OPC ('LEQ ', ULEQ);
ENTER_OPC ('LES ', ULES); ENTER_OPC ('IEQU', UIEQU);
ENTER_OPC ('INEQ', UINEQ); ENTER_OPC ('IGEQ', UIGEQ);
ENTER_OPC ('IGRT', UIGRT); ENTER_OPC ('ILEQ', UILEQ);
ENTER_OPC ('ILES', UILES); ENTER_OPC ('ILOD', UILOD);
ENTER_OPC ('MOV ', UMOV); ENTER_OPC ('IMPP', UIMPP);
ENTER_OPC ('IMPV', UIMPV); ENTER_OPC ('INC ', UINC);
ENTER_OPC ('INN ', UINN); ENTER_OPC ('INST', UINST);
ENTER_OPC ('INT ', UINT); ENTER_OPC ('IOR ', UIOR);
ENTER_OPC ('ISTR', UISTR); ENTER_OPC ('IXA ', UIXA);
ENTER_OPC ('LAB ', ULAB); ENTER_OPC ('LCA ', ULCA);
ENTER_OPC ('LDA ', ULDA); ENTER_OPC ('LDC ', ULDC);
ENTER_OPC ('LDP ', ULDP); ENTER_OPC ('LEX ', ULEX);
ENTER_OPC ('LIVE', ULIVE); ENTER_OPC ('LOC ', ULOC);
ENTER_OPC ('LOD ', ULOD); ENTER_OPC ('MDEF', UMDEF);
ENTER_OPC ('MOD ', UMOD); ENTER_OPC ('MST ', UMST);
ENTER_OPC ('MUS ', UMUS); ENTER_OPC ('NEG ', UNEG);
ENTER_OPC ('NEW ', UNEW); ENTER_OPC ('NOT ', UNOT);
ENTER_OPC ('NSTR', UNSTR); ENTER_OPC ('ODD ', UODD);
ENTER_OPC ('OPTN', UOPTN); ENTER_OPC ('PAR ', UPAR);
ENTER_OPC ('PLEX', UPLEX); ENTER_OPC ('PLOD', UPLOD);
ENTER_OPC ('PSTR', UPSTR); ENTER_OPC ('RET ', URET);
ENTER_OPC ('RND ', URND); ENTER_OPC ('SDEF', USDEF);
ENTER_OPC ('SGS ', USGS); ENTER_OPC ('SQR ', USQR);
ENTER_OPC ('STP ', USTP); ENTER_OPC ('STR ', USTR);
ENTER_OPC ('SWP ', USWP); ENTER_OPC ('SYM ', USYM);
ENTER_OPC ('TJP ', UTJP); ENTER_OPC ('TYP ', UTYP);
ENTER_OPC ('TYP2', UTYP2); ENTER_OPC ('UJP ', UUJP);
ENTER_OPC ('UNI ', UUNI); ENTER_OPC ('UNK ', UUNK);
ENTER_OPC ('XJP ', UXJP); ENTER_OPC ('XOR ', UXOR);
end (*INIT2*);
(** INITIALIZE_CLASS: INIT3 **)
(**)
procedure INIT3;
begin
for I := 0 to CSPHTSIZEM1 do
begin
CSPHASHTAB[I].CSPNAM.NAM := ' ';
CSPHASHTAB[I].CSPNAM.LEN := 1;
end;
ENTER_CSP ('ATN', QATN); ENTER_CSP ('EXP', QEXP);
ENTER_CSP ('SIN', QSIN); ENTER_CSP ('COS', QCOS);
ENTER_CSP ('LOG', QLOG); ENTER_CSP ('SQT', QSQT);
ENTER_CSP ('CLK', QCLK); ENTER_CSP ('XIT', QXIT);
ENTER_CSP ('TRP', QTRP); ENTER_CSP ('GET', QGET);
ENTER_CSP ('PUT', QPUT); ENTER_CSP ('RLN', QRLN);
ENTER_CSP ('WLN', QWLN); ENTER_CSP ('RES', QRES);
ENTER_CSP ('REW', QREW); ENTER_CSP ('RDC', QRDC);
ENTER_CSP ('RDI', QRDI); ENTER_CSP ('RDR', QRDR);
ENTER_CSP ('RDS', QRDS); ENTER_CSP ('WRC', QWRC);
ENTER_CSP ('RDB', QRDB); ENTER_CSP ('WRB', QWRB);
ENTER_CSP ('WRI', QWRI); ENTER_CSP ('WRR', QWRR);
ENTER_CSP ('WRS', QWRS); ENTER_CSP ('ELN', QELN);
ENTER_CSP ('EOF', QEOF); ENTER_CSP ('SIO', QSIO);
ENTER_CSP ('EIO', QEIO); ENTER_CSP ('NEW', QNEW);
ENTER_CSP ('SAV', QSAV); ENTER_CSP ('RST', QRST);
for S1OP := FIRSTS1OP to LASTS1OP do
REVERSE_OP[S1OP] := XILLEGAL;
REVERSE_OP[XADD_S] := XADD_S;
REVERSE_OP[XADD_D] := XADD_D;
REVERSE_OP[XAND_Q] := XAND_Q;
REVERSE_OP[XAND_D] := XAND_D;
REVERSE_OP[XAND_TC_D] := XAND_CT_D;
REVERSE_OP[XAND_CT_D] := XAND_TC_D;
REVERSE_OP[XFADD_S] := XFADD_S;
REVERSE_OP[XFADD_D] := XFADD_D;
REVERSE_OP[XFSUB_S] := XFSUBV_S;
REVERSE_OP[XFSUBV_S] := XFSUB_S;
REVERSE_OP[XFSUB_D] := XFSUBV_D;
REVERSE_OP[XFSUBV_D] := XFSUB_D;
REVERSE_OP[XFMULT_S] := XFMULT_S;
REVERSE_OP[XFMULT_D] := XFMULT_D;
REVERSE_OP[XFDIV_S] := XFDIVV_S;
REVERSE_OP[XFDIVV_S] := XFDIV_S;
REVERSE_OP[XFDIV_D] := XFDIVV_D;
REVERSE_OP[XFDIVV_D] := XFDIV_D;
REVERSE_OP[XMULT_S] := XMULT_S;
REVERSE_OP[XMULT_D] := XMULT_D;
REVERSE_OP[XNOP] := XNOP;
REVERSE_OP[XOR_Q] := XOR_Q;
REVERSE_OP[XOR_D] := XOR_D;
REVERSE_OP[XQUO_S] := XQUOV_S;
REVERSE_OP[XQUOV_S] := XQUO_S;
REVERSE_OP[XQUO_D] := XQUOV_D;
REVERSE_OP[XQUOV_D] := XQUO_D;
REVERSE_OP[XREM_S] := XREMV_S;
REVERSE_OP[XREMV_S] := XREM_S;
REVERSE_OP[XREM_D] := XREMV_D;
REVERSE_OP[XREMV_D] := XREM_D;
REVERSE_OP[XSHF_LF_D] := XSHFV_LF_D;
REVERSE_OP[XSHFV_LF_D] := XSHF_LF_D;
REVERSE_OP[XSHFA_LF_S] := XSHFAV_LF_S;
REVERSE_OP[XSHFAV_LF_S] := XSHFA_LF_S;
REVERSE_OP[XSUB_S] := XSUBV_S;
REVERSE_OP[XSUBV_S] := XSUB_S;
REVERSE_OP[XSUB_D] := XSUBV_D;
REVERSE_OP[XSUBV_D] := XSUB_D;
REVERSE_OP[XXOR_Q] := XXOR_Q;
OPFORMAT [XILLEGAL] := VFAKEOP;
OPFORMAT [XPLOC] := VFAKEOP;
OPFORMAT [XS1LOC] := VFAKEOP;
OPFORMAT [XFREEREG] := VFAKEOP; (*PBK*)
OPFORMAT [XABS_Q] := VXOP;
OPFORMAT [XABS_H] := VXOP;
OPFORMAT [XABS_S] := VXOP;
OPFORMAT [XABS_D] := VXOP;
OPFORMAT [XADD_S] := VTOP;
OPFORMAT [XADD_D] := VTOP;
OPFORMAT [XADJSP_UP] := VXOP;
OPFORMAT [XADJSP_DN] := VXOP;
OPFORMAT [XALLOC_1] := VXOP;
OPFORMAT [XAND_Q] := VTOP;
OPFORMAT [XAND_D] := VTOP;
OPFORMAT [XAND_TC_D] := VTOP;
OPFORMAT [XAND_CT_D] := VTOP;
OPFORMAT [XBLCMP_EQL_Q] := VXOP;
OPFORMAT [XBLCMP_NEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GTR_Q] := VXOP;
OPFORMAT [XBLCMP_LEQ_Q] := VXOP;
OPFORMAT [XBLCMP_LSS_Q] := VXOP;
OPFORMAT [XBLKMOV] := VXOP;
OPFORMAT [XBTRP_B_Q] := VXOP;
OPFORMAT [XBTRP_B_H] := VXOP;
OPFORMAT [XBTRP_B_S] := VXOP;
OPFORMAT [XBTRP_B_D] := VXOP;
OPFORMAT [XBTRP_M1_Q] := VXOP;
OPFORMAT [XBTRP_M1_H] := VXOP;
OPFORMAT [XBTRP_M1_S] := VXOP;
OPFORMAT [XBTRP_M1_D] := VXOP;
OPFORMAT [XBTRP_0_Q] := VXOP;
OPFORMAT [XBTRP_0_H] := VXOP;
OPFORMAT [XBTRP_0_S] := VXOP;
OPFORMAT [XBTRP_0_D] := VXOP;
OPFORMAT [XBTRP_1_Q] := VXOP;
OPFORMAT [XBTRP_1_H] := VXOP;
OPFORMAT [XBTRP_1_S] := VXOP;
OPFORMAT [XBTRP_1_D] := VXOP;
OPFORMAT [XDEC_S] := VXOP;
OPFORMAT [XFX_DM_S_S] := VXOP;
OPFORMAT [XFX_DM_S_D] := VXOP;
OPFORMAT [XFX_FL_S_S] := VXOP;
OPFORMAT [XFLOAT_S_Q] := VXOP;
OPFORMAT [XFLOAT_S_H] := VXOP;
OPFORMAT [XFLOAT_S_S] := VXOP;
OPFORMAT [XFLOAT_S_D] := VXOP;
OPFORMAT [XFADD_S] := VTOP;
OPFORMAT [XFADD_D] := VTOP;
OPFORMAT [XFSUB_S] := VTOP;
OPFORMAT [XFSUBV_S] := VTOP;
OPFORMAT [XFSUB_D] := VTOP;
OPFORMAT [XFSUBV_D] := VTOP;
OPFORMAT [XFMULT_S] := VTOP;
OPFORMAT [XFMULT_D] := VTOP;
OPFORMAT [XFDIV_S] := VTOP;
OPFORMAT [XFDIVV_S] := VTOP;
OPFORMAT [XFDIV_D] := VTOP;
OPFORMAT [XFDIVV_D] := VTOP;
OPFORMAT [XFTRANS_S_D] := VXOP;
OPFORMAT [XFTRANS_D_S] := VXOP;
OPFORMAT [XHALT] := VJOP; (*BNDTRPKLU*)
OPFORMAT [XINC_S] := VXOP;
OPFORMAT [XJMPA] := VJOP;
OPFORMAT [XJMPZ_EQL_Q] := VJOP;
OPFORMAT [XJMPZ_NEQ_Q] := VJOP; (* als/peg 19jul79 *)
OPFORMAT [XJSR] := VJOP;
OPFORMAT [XMOV_A] := VXOP;
OPFORMAT [XMOV_Q_Q] := VXOP;
OPFORMAT [XMOV_Q_H] := VXOP;
OPFORMAT [XMOV_H_Q] := VXOP;
OPFORMAT [XMOV_H_H] := VXOP;
OPFORMAT [XMOV_Q_S] := VXOP;
OPFORMAT [XMOV_H_S] := VXOP;
OPFORMAT [XMOV_S_Q] := VXOP;
OPFORMAT [XMOV_S_H] := VXOP;
OPFORMAT [XMOV_S_S] := VXOP;
OPFORMAT [XMOV_Q_D] := VXOP;
OPFORMAT [XMOV_H_D] := VXOP;
OPFORMAT [XMOV_S_D] := VXOP;
OPFORMAT [XMOV_D_Q] := VXOP;
OPFORMAT [XMOV_D_H] := VXOP;
OPFORMAT [XMOV_D_S] := VXOP;
OPFORMAT [XMOV_D_D] := VXOP;
OPFORMAT [XMOVMQ_2] := VXOP;
OPFORMAT [XMOVMQ_3] := VXOP;
OPFORMAT [XMOVMQ_4] := VXOP;
OPFORMAT [XMOVMQ_5] := VXOP;
OPFORMAT [XMOVMQ_6] := VXOP;
OPFORMAT [XMOVMQ_7] := VXOP;
OPFORMAT [XMOVMQ_8] := VXOP;
OPFORMAT [XMOVMQ_9] := VXOP;
OPFORMAT [XMOVMQ_10] := VXOP;
OPFORMAT [XMOVMQ_11] := VXOP;
OPFORMAT [XMOVMQ_12] := VXOP;
OPFORMAT [XMOVMQ_13] := VXOP;
OPFORMAT [XMOVMQ_14] := VXOP;
OPFORMAT [XMOVMQ_15] := VXOP;
OPFORMAT [XMOVMQ_16] := VXOP;
OPFORMAT [XMOVMQ_17] := VXOP;
OPFORMAT [XMOVMQ_18] := VXOP;
OPFORMAT [XMOVMQ_19] := VXOP;
OPFORMAT [XMOVMQ_20] := VXOP;
OPFORMAT [XMOVMQ_21] := VXOP;
OPFORMAT [XMOVMQ_22] := VXOP;
OPFORMAT [XMOVMQ_23] := VXOP;
OPFORMAT [XMOVMQ_24] := VXOP;
OPFORMAT [XMOVMQ_25] := VXOP;
OPFORMAT [XMOVMQ_26] := VXOP;
OPFORMAT [XMOVMQ_27] := VXOP;
OPFORMAT [XMOVMQ_28] := VXOP;
OPFORMAT [XMOVMQ_29] := VXOP;
OPFORMAT [XMOVMQ_30] := VXOP;
OPFORMAT [XMOVMQ_31] := VXOP;
OPFORMAT [XMOVMQ_32] := VXOP;
OPFORMAT [XMOVMQ_64] := VXOP;
OPFORMAT [XMOVMQ_128] := VXOP;
OPFORMAT [XMOVMS_2] := VXOP; (*ALS*)
OPFORMAT [XMOVMS_3] := VXOP;
OPFORMAT [XMOVMS_4] := VXOP;
OPFORMAT [XMOVMS_5] := VXOP;
OPFORMAT [XMOVMS_6] := VXOP;
OPFORMAT [XMOVMS_7] := VXOP;
OPFORMAT [XMOVMS_8] := VXOP;
OPFORMAT [XMOVMS_9] := VXOP;
OPFORMAT [XMOVMS_10] := VXOP;
OPFORMAT [XMOVMS_11] := VXOP;
OPFORMAT [XMOVMS_12] := VXOP;
OPFORMAT [XMOVMS_13] := VXOP;
OPFORMAT [XMOVMS_14] := VXOP;
OPFORMAT [XMOVMS_15] := VXOP;
OPFORMAT [XMOVMS_16] := VXOP;
OPFORMAT [XMOVMS_17] := VXOP;
OPFORMAT [XMOVMS_18] := VXOP;
OPFORMAT [XMOVMS_19] := VXOP;
OPFORMAT [XMOVMS_20] := VXOP;
OPFORMAT [XMOVMS_21] := VXOP;
OPFORMAT [XMOVMS_22] := VXOP;
OPFORMAT [XMOVMS_23] := VXOP;
OPFORMAT [XMOVMS_24] := VXOP;
OPFORMAT [XMOVMS_25] := VXOP;
OPFORMAT [XMOVMS_26] := VXOP;
OPFORMAT [XMOVMS_27] := VXOP;
OPFORMAT [XMOVMS_28] := VXOP;
OPFORMAT [XMOVMS_29] := VXOP;
OPFORMAT [XMOVMS_30] := VXOP;
OPFORMAT [XMOVMS_31] := VXOP;
OPFORMAT [XMOVMS_32] := VXOP; (*ALS*)
OPFORMAT [XMULT_S] := VTOP;
OPFORMAT [XMULT_D] := VTOP;
OPFORMAT [XDIV_S] := VTOP; (* als/peg 18jul79 *)
OPFORMAT [XNEG_Q] := VXOP;
OPFORMAT [XNEG_H] := VXOP;
OPFORMAT [XNEG_S] := VXOP;
OPFORMAT [XNEG_D] := VXOP;
OPFORMAT [XNOP] := VXOP;
OPFORMAT [XOR_Q] := VTOP;
OPFORMAT [XOR_D] := VTOP;
OPFORMAT [XQUO_S] := VTOP;
OPFORMAT [XQUOV_S] := VTOP;
OPFORMAT [XQUO_D] := VTOP;
OPFORMAT [XQUOV_D] := VTOP;
OPFORMAT [XREM_S] := VTOP;
OPFORMAT [XREMV_S] := VTOP;
OPFORMAT [XREM_D] := VTOP;
OPFORMAT [XREMV_D] := VTOP;
OPFORMAT [XRETSR] := VXOP;
OPFORMAT [XSHF_LF_D] := VTOP;
OPFORMAT [XSHFV_LF_D] := VTOP;
OPFORMAT [XSHFA_LF_S] := VTOP;
OPFORMAT [XSHFAV_LF_S] := VTOP;
OPFORMAT [XSKP_EQL_Q] := VSOP;
OPFORMAT [XSKP_NEQ_Q] := VSOP;
OPFORMAT [XSKP_GEQ_Q] := VSOP;
OPFORMAT [XSKP_GTR_Q] := VSOP;
OPFORMAT [XSKP_LEQ_Q] := VSOP;
OPFORMAT [XSKP_LSS_Q] := VSOP;
OPFORMAT [XSKP_EQL_H] := VSOP;
OPFORMAT [XSKP_NEQ_H] := VSOP;
OPFORMAT [XSKP_GEQ_H] := VSOP;
OPFORMAT [XSKP_GTR_H] := VSOP;
OPFORMAT [XSKP_LEQ_H] := VSOP;
OPFORMAT [XSKP_LSS_H] := VSOP;
OPFORMAT [XSKP_EQL_S] := VSOP;
OPFORMAT [XSKP_NEQ_S] := VSOP;
OPFORMAT [XSKP_GEQ_S] := VSOP;
OPFORMAT [XSKP_GTR_S] := VSOP;
OPFORMAT [XSKP_LEQ_S] := VSOP;
OPFORMAT [XSKP_LSS_S] := VSOP;
OPFORMAT [XSKP_EQL_D] := VSOP;
OPFORMAT [XSKP_NEQ_D] := VSOP;
OPFORMAT [XSKP_GEQ_D] := VSOP;
OPFORMAT [XSKP_GTR_D] := VSOP;
OPFORMAT [XSKP_LEQ_D] := VSOP;
OPFORMAT [XSKP_LSS_D] := VSOP;
OPFORMAT [XSKP_NON_Q] := VSOP;
OPFORMAT [XSKP_NON_H] := VSOP;
OPFORMAT [XSKP_NON_S] := VSOP;
OPFORMAT [XSKP_NON_D] := VSOP;
OPFORMAT [XSKP_ANY_Q] := VSOP;
OPFORMAT [XSKP_ANY_H] := VSOP;
OPFORMAT [XSKP_ANY_S] := VSOP;
OPFORMAT [XSKP_ANY_D] := VSOP;
OPFORMAT [XSLR_0] := VXOP;
OPFORMAT [XSLR_1] := VXOP;
OPFORMAT [XSLR_2] := VXOP;
OPFORMAT [XSLR_3] := VXOP;
OPFORMAT [XSLR_4] := VXOP;
OPFORMAT [XSLR_5] := VXOP;
OPFORMAT [XSLR_6] := VXOP;
OPFORMAT [XSLR_7] := VXOP;
OPFORMAT [XSLR_8] := VXOP;
OPFORMAT [XSLR_9] := VXOP;
OPFORMAT [XSLR_10] := VXOP;
OPFORMAT [XSLR_11] := VXOP;
OPFORMAT [XSLR_12] := VXOP;
OPFORMAT [XSLR_13] := VXOP;
OPFORMAT [XSLR_14] := VXOP;
OPFORMAT [XSLR_15] := VXOP;
OPFORMAT [XSLR_16] := VXOP;
OPFORMAT [XSLR_17] := VXOP;
OPFORMAT [XSLR_18] := VXOP;
OPFORMAT [XSLR_19] := VXOP;
OPFORMAT [XSLR_20] := VXOP;
OPFORMAT [XSLR_21] := VXOP;
OPFORMAT [XSLR_22] := VXOP;
OPFORMAT [XSLR_23] := VXOP;
OPFORMAT [XSLR_24] := VXOP;
OPFORMAT [XSLR_25] := VXOP;
OPFORMAT [XSLR_26] := VXOP;
OPFORMAT [XSLR_27] := VXOP;
OPFORMAT [XSLR_28] := VXOP;
OPFORMAT [XSLR_29] := VXOP;
OPFORMAT [XSLR_30] := VXOP;
OPFORMAT [XSLR_31] := VXOP;
OPFORMAT [XSLRADR_0] := VXOP;
OPFORMAT [XSLRADR_1] := VXOP;
OPFORMAT [XSLRADR_2] := VXOP;
OPFORMAT [XSLRADR_3] := VXOP;
OPFORMAT [XSLRADR_4] := VXOP;
OPFORMAT [XSLRADR_5] := VXOP;
OPFORMAT [XSLRADR_6] := VXOP;
OPFORMAT [XSLRADR_7] := VXOP;
OPFORMAT [XSLRADR_8] := VXOP;
OPFORMAT [XSLRADR_9] := VXOP;
OPFORMAT [XSLRADR_10] := VXOP;
OPFORMAT [XSLRADR_11] := VXOP;
OPFORMAT [XSLRADR_12] := VXOP;
OPFORMAT [XSLRADR_13] := VXOP;
OPFORMAT [XSLRADR_14] := VXOP;
OPFORMAT [XSLRADR_15] := VXOP;
OPFORMAT [XSLRADR_16] := VXOP;
OPFORMAT [XSLRADR_17] := VXOP;
OPFORMAT [XSLRADR_18] := VXOP;
OPFORMAT [XSLRADR_19] := VXOP;
OPFORMAT [XSLRADR_20] := VXOP;
OPFORMAT [XSLRADR_21] := VXOP;
OPFORMAT [XSLRADR_22] := VXOP;
OPFORMAT [XSLRADR_23] := VXOP;
OPFORMAT [XSLRADR_24] := VXOP;
OPFORMAT [XSLRADR_25] := VXOP;
OPFORMAT [XSLRADR_26] := VXOP;
OPFORMAT [XSLRADR_27] := VXOP;
OPFORMAT [XSLRADR_28] := VXOP;
OPFORMAT [XSLRADR_29] := VXOP;
OPFORMAT [XSLRADR_30] := VXOP;
OPFORMAT [XSLRADR_31] := VXOP;
OPFORMAT [XSUB_S] := VTOP;
OPFORMAT [XSUBV_S] := VTOP;
OPFORMAT [XSUB_D] := VTOP;
OPFORMAT [XSUBV_D] := VTOP;
OPFORMAT [XTRANS_Q_Q] := VXOP;
OPFORMAT [XTRANS_Q_H] := VXOP;
OPFORMAT [XTRANS_H_Q] := VXOP;
OPFORMAT [XTRANS_H_H] := VXOP;
OPFORMAT [XTRANS_Q_S] := VXOP;
OPFORMAT [XTRANS_H_S] := VXOP;
OPFORMAT [XTRANS_S_Q] := VXOP;
OPFORMAT [XTRANS_S_H] := VXOP;
OPFORMAT [XTRANS_S_S] := VXOP;
OPFORMAT [XTRANS_Q_D] := VXOP;
OPFORMAT [XTRANS_H_D] := VXOP;
OPFORMAT [XTRANS_S_D] := VXOP;
OPFORMAT [XTRANS_D_Q] := VXOP;
OPFORMAT [XTRANS_D_H] := VXOP;
OPFORMAT [XTRANS_D_S] := VXOP;
OPFORMAT [XTRANS_D_D] := VXOP;
OPFORMAT [XXOR_Q] := VTOP;
end (*INIT3*);
(** INITIALIZE_CLASS: INIT4 **)
(**)
procedure INIT4;
begin
S1MNEM [XILLEGAL] := 'ILLEGAL ';
S1MNEM [XPLOC] := 'ULOC ';
S1MNEM [XS1LOC] := 'S1LOC ';
S1MNEM [XFREEREG] := 'FREEREG '; (*PBK*)
% START S1MNEM MARKER FOR OPS.PAS \
S1MNEM [XABS_Q] := 'ABS.Q ';
S1MNEM [XABS_H] := 'ABS.H ';
S1MNEM [XABS_S] := 'ABS.S ';
S1MNEM [XABS_D] := 'ABS.D ';
S1MNEM [XADD_S] := 'ADD.S ';
S1MNEM [XADD_D] := 'ADD.D ';
S1MNEM [XADJSP_UP] := 'ADJSP.UP ';
S1MNEM [XADJSP_DN] := 'ADJSP.DN ';
S1MNEM [XALLOC_1] := 'ALLOC.1 ';
S1MNEM [XAND_Q] := 'AND.Q ';
S1MNEM [XAND_D] := 'AND.D ';
S1MNEM [XAND_TC_D] := 'ANDTC.D ';
S1MNEM [XAND_CT_D] := 'ANDCT.D ';
S1MNEM [XBLCMP_EQL_Q] := 'BLKCMP.EQL.Q ';
S1MNEM [XBLCMP_NEQ_Q] := 'BLKCMP.NEQ.Q ';
S1MNEM [XBLCMP_GEQ_Q] := 'BLKCMP.GEQ.Q ';
S1MNEM [XBLCMP_GTR_Q] := 'BLKCMP.GTR.Q ';
S1MNEM [XBLCMP_LEQ_Q] := 'BLKCMP.LEQ.Q ';
S1MNEM [XBLCMP_LSS_Q] := 'BLKCMP.LSS.Q ';
S1MNEM [XBLKMOV] := 'BLKMOV ';
S1MNEM [XBTRP_B_Q] := 'BNDTRP.B.Q ';
S1MNEM [XBTRP_B_H] := 'BNDTRP.B.H ';
S1MNEM [XBTRP_B_S] := 'BNDTRP.B.S ';
S1MNEM [XBTRP_B_D] := 'BNDTRP.B.D ';
S1MNEM [XBTRP_M1_Q] := 'BNDTRP.M1.Q ';
S1MNEM [XBTRP_M1_H] := 'BNDTRP.M1.H ';
S1MNEM [XBTRP_M1_S] := 'BNDTRP.M1.S ';
S1MNEM [XBTRP_M1_D] := 'BNDTRP.M1.D ';
S1MNEM [XBTRP_0_Q] := 'BNDTRP.0.Q ';
S1MNEM [XBTRP_0_H] := 'BNDTRP.0.H ';
S1MNEM [XBTRP_0_S] := 'BNDTRP.0.S ';
S1MNEM [XBTRP_0_D] := 'BNDTRP.0.D ';
S1MNEM [XBTRP_1_Q] := 'BNDTRP.1.Q ';
S1MNEM [XBTRP_1_H] := 'BNDTRP.1.H ';
S1MNEM [XBTRP_1_S] := 'BNDTRP.1.S ';
S1MNEM [XBTRP_1_D] := 'BNDTRP.1.D ';
S1MNEM [XDEC_S] := 'DEC.S ';
S1MNEM [XFX_DM_S_S] := 'FIX.DM.S.S ';
S1MNEM [XFX_DM_S_D] := 'FIX.DM.S.D ';
S1MNEM [XFX_FL_S_S] := 'FIX.FL.S.S ';
S1MNEM [XFLOAT_S_Q] := 'FLOAT.S.Q ';
S1MNEM [XFLOAT_S_H] := 'FLOAT.S.H ';
S1MNEM [XFLOAT_S_S] := 'FLOAT.S.S ';
S1MNEM [XFLOAT_S_D] := 'FLOAT.S.D ';
S1MNEM [XFADD_S] := 'FADD.S ';
S1MNEM [XFADD_D] := 'FADD.D ';
S1MNEM [XFSUB_S] := 'FSUB.S ';
S1MNEM [XFSUBV_S] := 'FSUBV.S ';
S1MNEM [XFSUB_D] := 'FSUB.D ';
S1MNEM [XFSUBV_D] := 'FSUBV.D ';
S1MNEM [XFMULT_S] := 'FMULT.S ';
S1MNEM [XFMULT_D] := 'FMULT.D ';
S1MNEM [XFDIV_S] := 'FDIV.S ';
S1MNEM [XFDIVV_S] := 'FDIVV.S ';
S1MNEM [XFDIV_D] := 'FDIV.D ';
S1MNEM [XFDIVV_D] := 'FDIVV.D ';
S1MNEM [XFTRANS_S_D] := 'FTRANS.S.D ';
S1MNEM [XFTRANS_D_S] := 'FTRANS.D.S ';
S1MNEM [XHALT] := 'HALT ';
S1MNEM [XINC_S] := 'INC.S ';
S1MNEM [XJMPA] := 'JMPA ';
S1MNEM [XJMPZ_EQL_Q] := 'JMPZ.EQL.Q ';
S1MNEM [XJMPZ_NEQ_Q] := 'JMPZ.NEQ.Q ';
S1MNEM [XJSR] := 'JSR ';
S1MNEM [XMOV_A] := 'MOVADR ';
S1MNEM [XMOV_Q_Q] := 'MOV.Q.Q ';
S1MNEM [XMOV_Q_H] := 'MOV.Q.H ';
S1MNEM [XMOV_H_Q] := 'MOV.H.Q ';
S1MNEM [XMOV_H_H] := 'MOV.H.H ';
S1MNEM [XMOV_Q_S] := 'MOV.Q.S ';
S1MNEM [XMOV_H_S] := 'MOV.H.S ';
S1MNEM [XMOV_S_Q] := 'MOV.S.Q ';
S1MNEM [XMOV_S_H] := 'MOV.S.H ';
S1MNEM [XMOV_S_S] := 'MOV.S.S ';
S1MNEM [XMOV_Q_D] := 'MOV.Q.D ';
S1MNEM [XMOV_H_D] := 'MOV.H.D ';
S1MNEM [XMOV_S_D] := 'MOV.S.D ';
S1MNEM [XMOV_D_Q] := 'MOV.D.Q ';
S1MNEM [XMOV_D_H] := 'MOV.D.H ';
S1MNEM [XMOV_D_S] := 'MOV.D.S ';
S1MNEM [XMOV_D_D] := 'MOV.D.D ';
S1MNEM [XMOVMQ_2] := 'MOVMQ.2 ';
S1MNEM [XMOVMQ_3] := 'MOVMQ.3 ';
S1MNEM [XMOVMQ_4] := 'MOVMQ.4 ';
S1MNEM [XMOVMQ_5] := 'MOVMQ.5 ';
S1MNEM [XMOVMQ_6] := 'MOVMQ.6 ';
S1MNEM [XMOVMQ_7] := 'MOVMQ.7 ';
S1MNEM [XMOVMQ_8] := 'MOVMQ.8 ';
S1MNEM [XMOVMQ_9] := 'MOVMQ.9 ';
S1MNEM [XMOVMQ_10] := 'MOVMQ.10 ';
S1MNEM [XMOVMQ_11] := 'MOVMQ.11 ';
S1MNEM [XMOVMQ_12] := 'MOVMQ.12 ';
S1MNEM [XMOVMQ_13] := 'MOVMQ.13 ';
S1MNEM [XMOVMQ_14] := 'MOVMQ.14 ';
S1MNEM [XMOVMQ_15] := 'MOVMQ.15 ';
S1MNEM [XMOVMQ_16] := 'MOVMQ.16 ';
S1MNEM [XMOVMQ_17] := 'MOVMQ.17 ';
S1MNEM [XMOVMQ_18] := 'MOVMQ.18 ';
S1MNEM [XMOVMQ_19] := 'MOVMQ.19 ';
S1MNEM [XMOVMQ_20] := 'MOVMQ.20 ';
S1MNEM [XMOVMQ_21] := 'MOVMQ.21 ';
S1MNEM [XMOVMQ_22] := 'MOVMQ.22 ';
S1MNEM [XMOVMQ_23] := 'MOVMQ.23 ';
S1MNEM [XMOVMQ_24] := 'MOVMQ.24 ';
S1MNEM [XMOVMQ_25] := 'MOVMQ.25 ';
S1MNEM [XMOVMQ_26] := 'MOVMQ.26 ';
S1MNEM [XMOVMQ_27] := 'MOVMQ.27 ';
S1MNEM [XMOVMQ_28] := 'MOVMQ.28 ';
S1MNEM [XMOVMQ_29] := 'MOVMQ.29 ';
S1MNEM [XMOVMQ_30] := 'MOVMQ.30 ';
S1MNEM [XMOVMQ_31] := 'MOVMQ.31 ';
S1MNEM [XMOVMQ_32] := 'MOVMQ.32 ';
S1MNEM [XMOVMQ_64] := 'MOVMQ.64 ';
S1MNEM [XMOVMQ_128] := 'MOVMQ.128 ';
S1MNEM [XMOVMS_2] := 'MOVMS.2 ';
S1MNEM [XMOVMS_3] := 'MOVMS.3 ';
S1MNEM [XMOVMS_4] := 'MOVMS.4 ';
S1MNEM [XMOVMS_5] := 'MOVMS.5 ';
S1MNEM [XMOVMS_6] := 'MOVMS.6 ';
S1MNEM [XMOVMS_7] := 'MOVMS.7 ';
S1MNEM [XMOVMS_8] := 'MOVMS.8 ';
S1MNEM [XMOVMS_9] := 'MOVMS.9 ';
S1MNEM [XMOVMS_10] := 'MOVMS.10 ';
S1MNEM [XMOVMS_11] := 'MOVMS.11 ';
S1MNEM [XMOVMS_12] := 'MOVMS.12 ';
S1MNEM [XMOVMS_13] := 'MOVMS.13 ';
S1MNEM [XMOVMS_14] := 'MOVMS.14 ';
S1MNEM [XMOVMS_15] := 'MOVMS.15 ';
S1MNEM [XMOVMS_16] := 'MOVMS.16 ';
S1MNEM [XMOVMS_17] := 'MOVMS.17 ';
S1MNEM [XMOVMS_18] := 'MOVMS.18 ';
S1MNEM [XMOVMS_19] := 'MOVMS.19 ';
S1MNEM [XMOVMS_20] := 'MOVMS.20 ';
S1MNEM [XMOVMS_21] := 'MOVMS.21 ';
S1MNEM [XMOVMS_22] := 'MOVMS.22 ';
S1MNEM [XMOVMS_23] := 'MOVMS.23 ';
S1MNEM [XMOVMS_24] := 'MOVMS.24 ';
S1MNEM [XMOVMS_25] := 'MOVMS.25 ';
S1MNEM [XMOVMS_26] := 'MOVMS.26 ';
S1MNEM [XMOVMS_27] := 'MOVMS.27 ';
S1MNEM [XMOVMS_28] := 'MOVMS.28 ';
S1MNEM [XMOVMS_29] := 'MOVMS.29 ';
S1MNEM [XMOVMS_30] := 'MOVMS.30 ';
S1MNEM [XMOVMS_31] := 'MOVMS.31 ';
S1MNEM [XMOVMS_32] := 'MOVMS.32 ';
S1MNEM [XMULT_S] := 'MULT.S ';
S1MNEM [XMULT_D] := 'MULT.D ';
S1MNEM [XDIV_S] := 'DIV.S ';
S1MNEM [XNEG_Q] := 'NEG.Q ';
S1MNEM [XNEG_H] := 'NEG.H ';
S1MNEM [XNEG_S] := 'NEG.S ';
S1MNEM [XNEG_D] := 'NEG.D ';
S1MNEM [XNOP] := 'NOP ';
S1MNEM [XOR_Q] := 'OR.Q ';
S1MNEM [XOR_D] := 'OR.D ';
S1MNEM [XQUO_S] := 'QUO.S ';
S1MNEM [XQUOV_S] := 'QUOV.S ';
S1MNEM [XQUO_D] := 'QUO.D ';
S1MNEM [XQUOV_D] := 'QUOV.D ';
S1MNEM [XREM_S] := 'REM.S ';
S1MNEM [XREMV_S] := 'REMV.S ';
S1MNEM [XREM_D] := 'REM.D ';
S1MNEM [XREMV_D] := 'REMV.D ';
S1MNEM [XRETSR] := 'RETSR ';
S1MNEM [XSHF_LF_D] := 'SHF.LF.D ';
S1MNEM [XSHFV_LF_D] := 'SHFV.LF.D ';
S1MNEM [XSHFA_LF_S] := 'SHFA.LF.S ';
S1MNEM [XSHFAV_LF_S] := 'SHFAV.LF.S ';
S1MNEM [XSKP_EQL_Q] := 'SKP.EQL.Q ';
S1MNEM [XSKP_NEQ_Q] := 'SKP.NEQ.Q ';
S1MNEM [XSKP_GEQ_Q] := 'SKP.GEQ.Q ';
S1MNEM [XSKP_GTR_Q] := 'SKP.GTR.Q ';
S1MNEM [XSKP_LEQ_Q] := 'SKP.LEQ.Q ';
S1MNEM [XSKP_LSS_Q] := 'SKP.LSS.Q ';
S1MNEM [XSKP_EQL_H] := 'SKP.EQL.H ';
S1MNEM [XSKP_NEQ_H] := 'SKP.NEQ.H ';
S1MNEM [XSKP_GEQ_H] := 'SKP.GEQ.H ';
S1MNEM [XSKP_GTR_H] := 'SKP.GTR.H ';
S1MNEM [XSKP_LEQ_H] := 'SKP.LEQ.H ';
S1MNEM [XSKP_LSS_H] := 'SKP.LSS.H ';
S1MNEM [XSKP_EQL_S] := 'SKP.EQL.S ';
S1MNEM [XSKP_NEQ_S] := 'SKP.NEQ.S ';
S1MNEM [XSKP_GEQ_S] := 'SKP.GEQ.S ';
S1MNEM [XSKP_GTR_S] := 'SKP.GTR.S ';
S1MNEM [XSKP_LEQ_S] := 'SKP.LEQ.S ';
S1MNEM [XSKP_LSS_S] := 'SKP.LSS.S ';
S1MNEM [XSKP_EQL_D] := 'SKP.EQL.D ';
S1MNEM [XSKP_NEQ_D] := 'SKP.NEQ.D ';
S1MNEM [XSKP_GEQ_D] := 'SKP.GEQ.D ';
S1MNEM [XSKP_GTR_D] := 'SKP.GTR.D ';
S1MNEM [XSKP_LEQ_D] := 'SKP.LEQ.D ';
S1MNEM [XSKP_LSS_D] := 'SKP.LSS.D ';
S1MNEM [XSKP_NON_Q] := 'SKP.NON.Q ';
S1MNEM [XSKP_NON_H] := 'SKP.NON.H ';
S1MNEM [XSKP_NON_S] := 'SKP.NON.S ';
S1MNEM [XSKP_NON_D] := 'SKP.NON.D ';
S1MNEM [XSKP_ANY_Q] := 'SKP.ANY.Q ';
S1MNEM [XSKP_ANY_H] := 'SKP.ANY.H ';
S1MNEM [XSKP_ANY_S] := 'SKP.ANY.S ';
S1MNEM [XSKP_ANY_D] := 'SKP.ANY.D ';
S1MNEM [XSLR_0] := 'SLR.0 ';
S1MNEM [XSLR_1] := 'SLR.1 ';
S1MNEM [XSLR_2] := 'SLR.2 ';
S1MNEM [XSLR_3] := 'SLR.3 ';
S1MNEM [XSLR_4] := 'SLR.4 ';
S1MNEM [XSLR_5] := 'SLR.5 ';
S1MNEM [XSLR_6] := 'SLR.6 ';
S1MNEM [XSLR_7] := 'SLR.7 ';
S1MNEM [XSLR_8] := 'SLR.8 ';
S1MNEM [XSLR_9] := 'SLR.9 ';
S1MNEM [XSLR_10] := 'SLR.10 ';
S1MNEM [XSLR_11] := 'SLR.11 ';
S1MNEM [XSLR_12] := 'SLR.12 ';
S1MNEM [XSLR_13] := 'SLR.13 ';
S1MNEM [XSLR_14] := 'SLR.14 ';
S1MNEM [XSLR_15] := 'SLR.15 ';
S1MNEM [XSLR_16] := 'SLR.16 ';
S1MNEM [XSLR_17] := 'SLR.17 ';
S1MNEM [XSLR_18] := 'SLR.18 ';
S1MNEM [XSLR_19] := 'SLR.19 ';
S1MNEM [XSLR_20] := 'SLR.20 ';
S1MNEM [XSLR_21] := 'SLR.21 ';
S1MNEM [XSLR_22] := 'SLR.22 ';
S1MNEM [XSLR_23] := 'SLR.23 ';
S1MNEM [XSLR_24] := 'SLR.24 ';
S1MNEM [XSLR_25] := 'SLR.25 ';
S1MNEM [XSLR_26] := 'SLR.26 ';
S1MNEM [XSLR_27] := 'SLR.27 ';
S1MNEM [XSLR_28] := 'SLR.28 ';
S1MNEM [XSLR_29] := 'SLR.29 ';
S1MNEM [XSLR_30] := 'SLR.30 ';
S1MNEM [XSLR_31] := 'SLR.31 ';
S1MNEM [XSLRADR_0] := 'SLRADR.0 ';
S1MNEM [XSLRADR_1] := 'SLRADR.1 ';
S1MNEM [XSLRADR_2] := 'SLRADR.2 ';
S1MNEM [XSLRADR_3] := 'SLRADR.3 ';
S1MNEM [XSLRADR_4] := 'SLRADR.4 ';
S1MNEM [XSLRADR_5] := 'SLRADR.5 ';
S1MNEM [XSLRADR_6] := 'SLRADR.6 ';
S1MNEM [XSLRADR_7] := 'SLRADR.7 ';
S1MNEM [XSLRADR_8] := 'SLRADR.8 ';
S1MNEM [XSLRADR_9] := 'SLRADR.9 ';
S1MNEM [XSLRADR_10] := 'SLRADR.10 ';
S1MNEM [XSLRADR_11] := 'SLRADR.11 ';
S1MNEM [XSLRADR_12] := 'SLRADR.12 ';
S1MNEM [XSLRADR_13] := 'SLRADR.13 ';
S1MNEM [XSLRADR_14] := 'SLRADR.14 ';
S1MNEM [XSLRADR_15] := 'SLRADR.15 ';
S1MNEM [XSLRADR_16] := 'SLRADR.16 ';
S1MNEM [XSLRADR_17] := 'SLRADR.17 ';
S1MNEM [XSLRADR_18] := 'SLRADR.18 ';
S1MNEM [XSLRADR_19] := 'SLRADR.19 ';
S1MNEM [XSLRADR_20] := 'SLRADR.20 ';
S1MNEM [XSLRADR_21] := 'SLRADR.21 ';
S1MNEM [XSLRADR_22] := 'SLRADR.22 ';
S1MNEM [XSLRADR_23] := 'SLRADR.23 ';
S1MNEM [XSLRADR_24] := 'SLRADR.24 ';
S1MNEM [XSLRADR_25] := 'SLRADR.25 ';
S1MNEM [XSLRADR_26] := 'SLRADR.26 ';
S1MNEM [XSLRADR_27] := 'SLRADR.27 ';
S1MNEM [XSLRADR_28] := 'SLRADR.28 ';
S1MNEM [XSLRADR_29] := 'SLRADR.29 ';
S1MNEM [XSLRADR_30] := 'SLRADR.30 ';
S1MNEM [XSLRADR_31] := 'SLRADR.31 ';
S1MNEM [XSUB_S] := 'SUB.S ';
S1MNEM [XSUBV_S] := 'SUBV.S ';
S1MNEM [XSUB_D] := 'SUB.D ';
S1MNEM [XSUBV_D] := 'SUBV.D ';
S1MNEM [XTRANS_Q_Q] := 'TRANS.Q.Q ';
S1MNEM [XTRANS_Q_H] := 'TRANS.Q.H ';
S1MNEM [XTRANS_H_Q] := 'TRANS.H.Q ';
S1MNEM [XTRANS_H_H] := 'TRANS.H.H ';
S1MNEM [XTRANS_Q_S] := 'TRANS.Q.S ';
S1MNEM [XTRANS_H_S] := 'TRANS.H.S ';
S1MNEM [XTRANS_S_Q] := 'TRANS.S.Q ';
S1MNEM [XTRANS_S_H] := 'TRANS.S.H ';
S1MNEM [XTRANS_S_S] := 'TRANS.S.S ';
S1MNEM [XTRANS_Q_D] := 'TRANS.Q.D ';
S1MNEM [XTRANS_H_D] := 'TRANS.H.D ';
S1MNEM [XTRANS_S_D] := 'TRANS.S.D ';
S1MNEM [XTRANS_D_Q] := 'TRANS.D.Q ';
S1MNEM [XTRANS_D_H] := 'TRANS.D.H ';
S1MNEM [XTRANS_D_S] := 'TRANS.D.S ';
S1MNEM [XTRANS_D_D] := 'TRANS.D.D ';
S1MNEM [XXOR_Q] := 'XOR.Q ';
% END S1MNEM MARKER FOR OPS.PAS \
end (*INIT4*);
(** INITIALIZE_CLASS: INIT5 **)
(**)
procedure INIT5;
begin
(* HARDOPCODEs for FAKEOPs should start at 4095 and work down. PBK*)
HARDOPCODE [XILLEGAL ] := 4095; (*PBK*)
HARDOPCODE [XPLOC ] := 4094; (*PBK*)
HARDOPCODE [XS1LOC ] := 4093; (*PBK*)
HARDOPCODE [XFREEREG ] := 4092; (*PBK*)
(* GENERATED SOPA OPCODES USING OPS.IN OF 13DEC78 2219 JBR *)
HARDOPCODE [XABS_Q ] := 1487;
HARDOPCODE [XABS_H ] := 1488;
HARDOPCODE [XABS_S ] := 1489;
HARDOPCODE [XABS_D ] := 1490;
HARDOPCODE [XADD_S ] := 12;
HARDOPCODE [XADD_D ] := 16;
HARDOPCODE [XADJSP_UP ] := 1830;
HARDOPCODE [XADJSP_DN ] := 1831;
HARDOPCODE [XALLOC_1 ] := 1666;
HARDOPCODE [XAND_Q ] := 736;
HARDOPCODE [XAND_D ] := 748;
HARDOPCODE [XAND_TC_D ] := 764;
HARDOPCODE [XAND_CT_D ] := 780;
HARDOPCODE [XBLCMP_EQL_Q ] := 1866;
HARDOPCODE [XBLCMP_NEQ_Q ] := 1878;
HARDOPCODE [XBLCMP_GEQ_Q ] := 1870;
HARDOPCODE [XBLCMP_GTR_Q ] := 1862;
HARDOPCODE [XBLCMP_LEQ_Q ] := 1882;
HARDOPCODE [XBLCMP_LSS_Q ] := 1874;
HARDOPCODE [XBLKMOV ] := 1886;
HARDOPCODE [XBTRP_B_Q ] := 1645;
HARDOPCODE [XBTRP_B_H ] := 1646;
HARDOPCODE [XBTRP_B_S ] := 1647;
HARDOPCODE [XBTRP_B_D ] := 1648;
HARDOPCODE [XBTRP_M1_Q ] := 1653;
HARDOPCODE [XBTRP_M1_H ] := 1654;
HARDOPCODE [XBTRP_M1_S ] := 1655;
HARDOPCODE [XBTRP_M1_D ] := 1656;
HARDOPCODE [XBTRP_0_Q ] := 1657;
HARDOPCODE [XBTRP_0_H ] := 1658;
HARDOPCODE [XBTRP_0_S ] := 1659;
HARDOPCODE [XBTRP_0_D ] := 1660;
HARDOPCODE [XBTRP_1_Q ] := 1661;
HARDOPCODE [XBTRP_1_H ] := 1662;
HARDOPCODE [XBTRP_1_S ] := 1663;
HARDOPCODE [XBTRP_1_D ] := 1664;
HARDOPCODE [XDEC_S ] := 1384;
HARDOPCODE [XFX_DM_S_S ] := 1433;
HARDOPCODE [XFX_DM_S_D ] := 1434;
HARDOPCODE [XFX_FL_S_S ] := 1409;
HARDOPCODE [XFLOAT_S_Q ] := 1466;
HARDOPCODE [XFLOAT_S_H ] := 1467;
HARDOPCODE [XFLOAT_S_S ] := 1468;
HARDOPCODE [XFLOAT_S_D ] := 1469;
HARDOPCODE [XFADD_S ] := 412;
HARDOPCODE [XFADD_D ] := 416;
HARDOPCODE [XFSUB_S ] := 424;
HARDOPCODE [XFSUBV_S ] := 436;
HARDOPCODE [XFSUB_D ] := 428;
HARDOPCODE [XFSUBV_D ] := 440;
HARDOPCODE [XFMULT_S ] := 448;
HARDOPCODE [XFMULT_D ] := 452;
HARDOPCODE [XFDIV_S ] := 468;
HARDOPCODE [XFDIVV_S ] := 480;
HARDOPCODE [XFDIV_D ] := 472;
HARDOPCODE [XFDIVV_D ] := 484;
HARDOPCODE [XFTRANS_S_D ] := 1479;
HARDOPCODE [XFTRANS_D_S ] := 1481;
HARDOPCODE [XHALT ] := 1376;
HARDOPCODE [XINC_S ] := 1380;
HARDOPCODE [XJMPA ] := 1296;
HARDOPCODE [XJMPZ_EQL_Q ] := 1256;
HARDOPCODE [XJMPZ_NEQ_Q ] := 1280;
HARDOPCODE [XJSR ] := 1350;
HARDOPCODE [XMOV_A ] := 1639;
HARDOPCODE [XMOV_Q_Q ] := 1491;
HARDOPCODE [XMOV_Q_H ] := 1492;
HARDOPCODE [XMOV_H_Q ] := 1495;
HARDOPCODE [XMOV_H_H ] := 1496;
HARDOPCODE [XMOV_Q_S ] := 1493;
HARDOPCODE [XMOV_H_S ] := 1497;
HARDOPCODE [XMOV_S_Q ] := 1499;
HARDOPCODE [XMOV_S_H ] := 1500;
HARDOPCODE [XMOV_S_S ] := 1501;
HARDOPCODE [XMOV_Q_D ] := 1494;
HARDOPCODE [XMOV_H_D ] := 1498;
HARDOPCODE [XMOV_S_D ] := 1502;
HARDOPCODE [XMOV_D_Q ] := 1503;
HARDOPCODE [XMOV_D_H ] := 1504;
HARDOPCODE [XMOV_D_S ] := 1505;
HARDOPCODE [XMOV_D_D ] := 1506;
HARDOPCODE [XMOVMQ_2 ] := 1507;
HARDOPCODE [XMOVMQ_3 ] := 1508;
HARDOPCODE [XMOVMQ_4 ] := 1509;
HARDOPCODE [XMOVMQ_5 ] := 1510;
HARDOPCODE [XMOVMQ_6 ] := 1511;
HARDOPCODE [XMOVMQ_7 ] := 1512;
HARDOPCODE [XMOVMQ_8 ] := 1513;
HARDOPCODE [XMOVMQ_9 ] := 1514;
HARDOPCODE [XMOVMQ_10 ] := 1515;
HARDOPCODE [XMOVMQ_11 ] := 1516;
HARDOPCODE [XMOVMQ_12 ] := 1517;
HARDOPCODE [XMOVMQ_13 ] := 1518;
HARDOPCODE [XMOVMQ_14 ] := 1519;
HARDOPCODE [XMOVMQ_15 ] := 1520;
HARDOPCODE [XMOVMQ_16 ] := 1521;
HARDOPCODE [XMOVMQ_17 ] := 1522;
HARDOPCODE [XMOVMQ_18 ] := 1523;
HARDOPCODE [XMOVMQ_19 ] := 1524;
HARDOPCODE [XMOVMQ_20 ] := 1525;
HARDOPCODE [XMOVMQ_21 ] := 1526;
HARDOPCODE [XMOVMQ_22 ] := 1527;
HARDOPCODE [XMOVMQ_23 ] := 1528;
HARDOPCODE [XMOVMQ_24 ] := 1529;
HARDOPCODE [XMOVMQ_25 ] := 1530;
HARDOPCODE [XMOVMQ_26 ] := 1531;
HARDOPCODE [XMOVMQ_27 ] := 1532;
HARDOPCODE [XMOVMQ_28 ] := 1533;
HARDOPCODE [XMOVMQ_29 ] := 1534;
HARDOPCODE [XMOVMQ_30 ] := 1535;
HARDOPCODE [XMOVMQ_31 ] := 1536;
HARDOPCODE [XMOVMQ_32 ] := 1537;
HARDOPCODE [XMOVMQ_64 ] := 1538;
HARDOPCODE [XMOVMQ_128 ] := 1539;
HARDOPCODE [XMOVMS_2 ] := 1540;
HARDOPCODE [XMOVMS_3 ] := 1541;
HARDOPCODE [XMOVMS_4 ] := 1542;
HARDOPCODE [XMOVMS_5 ] := 1543;
HARDOPCODE [XMOVMS_6 ] := 1544;
HARDOPCODE [XMOVMS_7 ] := 1545;
HARDOPCODE [XMOVMS_8 ] := 1546;
HARDOPCODE [XMOVMS_9 ] := 1547;
HARDOPCODE [XMOVMS_10 ] := 1548;
HARDOPCODE [XMOVMS_11 ] := 1549;
HARDOPCODE [XMOVMS_12 ] := 1550;
HARDOPCODE [XMOVMS_13 ] := 1551;
HARDOPCODE [XMOVMS_14 ] := 1552;
HARDOPCODE [XMOVMS_15 ] := 1553;
HARDOPCODE [XMOVMS_16 ] := 1554;
HARDOPCODE [XMOVMS_17 ] := 1555;
HARDOPCODE [XMOVMS_18 ] := 1556;
HARDOPCODE [XMOVMS_19 ] := 1557;
HARDOPCODE [XMOVMS_20 ] := 1558;
HARDOPCODE [XMOVMS_21 ] := 1559;
HARDOPCODE [XMOVMS_22 ] := 1560;
HARDOPCODE [XMOVMS_23 ] := 1561;
HARDOPCODE [XMOVMS_24 ] := 1562;
HARDOPCODE [XMOVMS_25 ] := 1563;
HARDOPCODE [XMOVMS_26 ] := 1564;
HARDOPCODE [XMOVMS_27 ] := 1565;
HARDOPCODE [XMOVMS_28 ] := 1566;
HARDOPCODE [XMOVMS_29 ] := 1567;
HARDOPCODE [XMOVMS_30 ] := 1568;
HARDOPCODE [XMOVMS_31 ] := 1569;
HARDOPCODE [XMOVMS_32 ] := 1570;
HARDOPCODE [XMULT_S ] := 108;
HARDOPCODE [XMULT_D ] := 112;
HARDOPCODE [XDIV_S ] := 360;
HARDOPCODE [XNEG_Q ] := 1483;
HARDOPCODE [XNEG_H ] := 1484;
HARDOPCODE [XNEG_S ] := 1485;
HARDOPCODE [XNEG_D ] := 1486;
HARDOPCODE [XNOP ] := 1939;
HARDOPCODE [XOR_Q ] := 784;
HARDOPCODE [XOR_D ] := 796;
HARDOPCODE [XQUO_S ] := 136;
HARDOPCODE [XQUOV_S ] := 152;
HARDOPCODE [XQUO_D ] := 140;
HARDOPCODE [XQUOV_D ] := 156;
HARDOPCODE [XREM_S ] := 248;
HARDOPCODE [XREMV_S ] := 264;
HARDOPCODE [XREM_D ] := 252;
HARDOPCODE [XREMV_D ] := 268;
HARDOPCODE [XRETSR ] := 1698;
HARDOPCODE [XSHF_LF_D ] := 908;
HARDOPCODE [XSHFV_LF_D ] := 940;
HARDOPCODE [XSHFA_LF_S ] := 1016;
HARDOPCODE [XSHFAV_LF_S ] := 1048;
HARDOPCODE [XSKP_EQL_Q ] := 2112;
HARDOPCODE [XSKP_NEQ_Q ] := 2304;
HARDOPCODE [XSKP_GEQ_Q ] := 2176;
HARDOPCODE [XSKP_GTR_Q ] := 2048;
HARDOPCODE [XSKP_LEQ_Q ] := 2368;
HARDOPCODE [XSKP_LSS_Q ] := 2240;
HARDOPCODE [XSKP_EQL_H ] := 2128;
HARDOPCODE [XSKP_NEQ_H ] := 2320;
HARDOPCODE [XSKP_GEQ_H ] := 2192;
HARDOPCODE [XSKP_GTR_H ] := 2064;
HARDOPCODE [XSKP_LEQ_H ] := 2384;
HARDOPCODE [XSKP_LSS_H ] := 2256;
HARDOPCODE [XSKP_EQL_S ] := 2144;
HARDOPCODE [XSKP_NEQ_S ] := 2336;
HARDOPCODE [XSKP_GEQ_S ] := 2208;
HARDOPCODE [XSKP_GTR_S ] := 2080;
HARDOPCODE [XSKP_LEQ_S ] := 2400;
HARDOPCODE [XSKP_LSS_S ] := 2272;
HARDOPCODE [XSKP_EQL_D ] := 2160;
HARDOPCODE [XSKP_NEQ_D ] := 2352;
HARDOPCODE [XSKP_GEQ_D ] := 2224;
HARDOPCODE [XSKP_GTR_D ] := 2096;
HARDOPCODE [XSKP_LEQ_D ] := 2416;
HARDOPCODE [XSKP_LSS_D ] := 2288;
HARDOPCODE [XSKP_NON_Q ] := 2432;
HARDOPCODE [XSKP_NON_H ] := 2448;
HARDOPCODE [XSKP_NON_S ] := 2464;
HARDOPCODE [XSKP_NON_D ] := 2480;
HARDOPCODE [XSKP_ANY_Q ] := 2624;
HARDOPCODE [XSKP_ANY_H ] := 2640;
HARDOPCODE [XSKP_ANY_S ] := 2656;
HARDOPCODE [XSKP_ANY_D ] := 2672;
HARDOPCODE [XSLR_0 ] := 1575;
HARDOPCODE [XSLR_1 ] := 1576;
HARDOPCODE [XSLR_2 ] := 1577;
HARDOPCODE [XSLR_3 ] := 1578;
HARDOPCODE [XSLR_4 ] := 1579;
HARDOPCODE [XSLR_5 ] := 1580;
HARDOPCODE [XSLR_6 ] := 1581;
HARDOPCODE [XSLR_7 ] := 1582;
HARDOPCODE [XSLR_8 ] := 1583;
HARDOPCODE [XSLR_9 ] := 1584;
HARDOPCODE [XSLR_10 ] := 1585;
HARDOPCODE [XSLR_11 ] := 1586;
HARDOPCODE [XSLR_12 ] := 1587;
HARDOPCODE [XSLR_13 ] := 1588;
HARDOPCODE [XSLR_14 ] := 1589;
HARDOPCODE [XSLR_15 ] := 1590;
HARDOPCODE [XSLR_16 ] := 1591;
HARDOPCODE [XSLR_17 ] := 1592;
HARDOPCODE [XSLR_18 ] := 1593;
HARDOPCODE [XSLR_19 ] := 1594;
HARDOPCODE [XSLR_20 ] := 1595;
HARDOPCODE [XSLR_21 ] := 1596;
HARDOPCODE [XSLR_22 ] := 1597;
HARDOPCODE [XSLR_23 ] := 1598;
HARDOPCODE [XSLR_24 ] := 1599;
HARDOPCODE [XSLR_25 ] := 1600;
HARDOPCODE [XSLR_26 ] := 1601;
HARDOPCODE [XSLR_27 ] := 1602;
HARDOPCODE [XSLR_28 ] := 1603;
HARDOPCODE [XSLR_29 ] := 1604;
HARDOPCODE [XSLR_30 ] := 1605;
HARDOPCODE [XSLR_31 ] := 1606;
HARDOPCODE [XSLRADR_0 ] := 1607;
HARDOPCODE [XSLRADR_1 ] := 1608;
HARDOPCODE [XSLRADR_2 ] := 1609;
HARDOPCODE [XSLRADR_3 ] := 1610;
HARDOPCODE [XSLRADR_4 ] := 1611;
HARDOPCODE [XSLRADR_5 ] := 1612;
HARDOPCODE [XSLRADR_6 ] := 1613;
HARDOPCODE [XSLRADR_7 ] := 1614;
HARDOPCODE [XSLRADR_8 ] := 1615;
HARDOPCODE [XSLRADR_9 ] := 1616;
HARDOPCODE [XSLRADR_10 ] := 1617;
HARDOPCODE [XSLRADR_11 ] := 1618;
HARDOPCODE [XSLRADR_12 ] := 1619;
HARDOPCODE [XSLRADR_13 ] := 1620;
HARDOPCODE [XSLRADR_14 ] := 1621;
HARDOPCODE [XSLRADR_15 ] := 1622;
HARDOPCODE [XSLRADR_16 ] := 1623;
HARDOPCODE [XSLRADR_17 ] := 1624;
HARDOPCODE [XSLRADR_18 ] := 1625;
HARDOPCODE [XSLRADR_19 ] := 1626;
HARDOPCODE [XSLRADR_20 ] := 1627;
HARDOPCODE [XSLRADR_21 ] := 1628;
HARDOPCODE [XSLRADR_22 ] := 1629;
HARDOPCODE [XSLRADR_23 ] := 1630;
HARDOPCODE [XSLRADR_24 ] := 1631;
HARDOPCODE [XSLRADR_25 ] := 1632;
HARDOPCODE [XSLRADR_26 ] := 1633;
HARDOPCODE [XSLRADR_27 ] := 1634;
HARDOPCODE [XSLRADR_28 ] := 1635;
HARDOPCODE [XSLRADR_29 ] := 1636;
HARDOPCODE [XSLRADR_30 ] := 1637;
HARDOPCODE [XSLRADR_31 ] := 1638;
HARDOPCODE [XSUB_S ] := 44;
HARDOPCODE [XSUBV_S ] := 60;
HARDOPCODE [XSUB_D ] := 48;
HARDOPCODE [XSUBV_D ] := 64;
HARDOPCODE [XTRANS_Q_Q ] := 1386;
HARDOPCODE [XTRANS_Q_H ] := 1387;
HARDOPCODE [XTRANS_H_Q ] := 1390;
HARDOPCODE [XTRANS_H_H ] := 1391;
HARDOPCODE [XTRANS_Q_S ] := 1388;
HARDOPCODE [XTRANS_H_S ] := 1392;
HARDOPCODE [XTRANS_S_Q ] := 1394;
HARDOPCODE [XTRANS_S_H ] := 1395;
HARDOPCODE [XTRANS_S_S ] := 1396;
HARDOPCODE [XTRANS_Q_D ] := 1389;
HARDOPCODE [XTRANS_H_D ] := 1393;
HARDOPCODE [XTRANS_S_D ] := 1397;
HARDOPCODE [XTRANS_D_Q ] := 1398;
HARDOPCODE [XTRANS_D_H ] := 1399;
HARDOPCODE [XTRANS_D_S ] := 1400;
HARDOPCODE [XTRANS_D_D ] := 1401;
HARDOPCODE [XXOR_Q ] := 864;
end (*INIT5*);
(** INITIALIZE_CLASS: INIT6 **)
(**)
procedure INIT6;
begin
INVERSE_SKIP [XSKP_EQL_Q] := XSKP_NEQ_Q;
INVERSE_SKIP [XSKP_NEQ_Q] := XSKP_EQL_Q;
INVERSE_SKIP [XSKP_GEQ_Q] := XSKP_LSS_Q;
INVERSE_SKIP [XSKP_LSS_Q] := XSKP_GEQ_Q;
INVERSE_SKIP [XSKP_GTR_Q] := XSKP_LEQ_Q;
INVERSE_SKIP [XSKP_LEQ_Q] := XSKP_GTR_Q;
INVERSE_SKIP [XSKP_EQL_H] := XSKP_NEQ_H;
INVERSE_SKIP [XSKP_NEQ_H] := XSKP_EQL_H;
INVERSE_SKIP [XSKP_GEQ_H] := XSKP_LSS_H;
INVERSE_SKIP [XSKP_LSS_H] := XSKP_GEQ_H;
INVERSE_SKIP [XSKP_GTR_H] := XSKP_LEQ_H;
INVERSE_SKIP [XSKP_LEQ_H] := XSKP_GTR_H;
INVERSE_SKIP [XSKP_EQL_S] := XSKP_NEQ_S;
INVERSE_SKIP [XSKP_NEQ_S] := XSKP_EQL_S;
INVERSE_SKIP [XSKP_GEQ_S] := XSKP_LSS_S;
INVERSE_SKIP [XSKP_LSS_S] := XSKP_GEQ_S;
INVERSE_SKIP [XSKP_GTR_S] := XSKP_LEQ_S;
INVERSE_SKIP [XSKP_LEQ_S] := XSKP_GTR_S;
INVERSE_SKIP [XSKP_EQL_D] := XSKP_NEQ_D;
INVERSE_SKIP [XSKP_NEQ_D] := XSKP_EQL_D;
INVERSE_SKIP [XSKP_GEQ_D] := XSKP_LSS_D;
INVERSE_SKIP [XSKP_LSS_D] := XSKP_GEQ_D;
INVERSE_SKIP [XSKP_GTR_D] := XSKP_LEQ_D;
INVERSE_SKIP [XSKP_LEQ_D] := XSKP_GTR_D;
INVERSE_SKIP [XSKP_NON_Q] := XSKP_ANY_Q;
INVERSE_SKIP [XSKP_NON_H] := XSKP_ANY_H;
INVERSE_SKIP [XSKP_NON_S] := XSKP_ANY_S;
INVERSE_SKIP [XSKP_NON_D] := XSKP_ANY_D;
INVERSE_SKIP [XSKP_ANY_Q] := XSKP_NON_Q;
INVERSE_SKIP [XSKP_ANY_H] := XSKP_NON_H;
INVERSE_SKIP [XSKP_ANY_S] := XSKP_NON_S;
INVERSE_SKIP [XSKP_ANY_D] := XSKP_NON_D;
for S1OP := FIRSTS1OP to LASTS1OP do
begin
case OPFORMAT[S1OP] of
VFAKEOP, VXOP : N := 1;
VTOP : N := TWOEXP[T_LEN];
VJOP : N := TWOEXP[PR_LEN];
VSOP : N := TWOEXP[SKP_LEN];
end (*case*);
if not ( HARDOPCODE[S1OP] mod N = 0) then ASSERTFAIL('INITIALIZ001');
for I := HARDOPCODE[S1OP] to (HARDOPCODE[S1OP]+N-1) do
SOFTOPCODE[I] := S1OP;
end (*for S1OP := *);
for S1OP := FIRSTS1OP to LASTS1OP do S1OP_CNT[S1OP] := 0; (*LCW*)
WORD_CNT := 0; (*LCW*)
GETFIELD_CNT := 0; (*PTZ*)
INSTR_WDS_REMOVED := 0; (*PTZ*)
J_TO_J_CNT := 0; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS := 0; (*PTZ*)
MOVS_COLLAPSED := 0; (*PTZ*)
TR_PEEPHOLE := false; (*15JAN79 PTZ*)
TR_UCODE := false;
TR_S1CODE := false;
TR_STACK := false;
TR_MST := false;
% TR_NEST := false; \(* peg 18jul79*)
TR_SIMP := false;
MAINCODE := EMPTYCODELIST;
NEWINSTREC := nil;
BOT := 1; (*STKINX of the first datum on STK*)(* peg 09jul79 *)
TOP := BOT-1;
CURFRAME := MINFRAME; (* peg 09jul79 *)
STKFRAME[CURFRAME] := BOT; (* peg 09jul79 *)
PREGS_ARCHIVED := false; (* als/peg 18jul79 *)
MSTTOP := 0;
with MSTSTK[MSTTOP] do
begin
DESTLEV := 1;
MSTCODESTART := nil;
CURPARMREGS := 0;
EVALSAVESTART := 0;
end (*with MSTSTK[TOP] do*);
DEBUG := false;
ASM := false;
ERRORCNT := 0;
MAXLVLUSED := 0;
end (*INIT6*);
(** INITIALIZE_CLASS: INIT7 **)
(**)
procedure INIT7; (*PBK*)
var S1OP : S1OPCODE;
begin
(*Right now COLLAPSIBLE_OP[S1OP] = false iff DEST_PRECISION[S1OP]
= S1ILLEGAL. Someone ought to monitor this & remove COLLAPSIBLE_OP
if the situation persists for a long time. 9/24/78 PTZ*)
(**** What the heck is this array for?? There are some 'new' opcodes
-- should they be in this list?? -- als/peg 18jul79*)
for S1OP := FIRSTS1OP to LASTS1OP do
COLLAPSIBLE_OP [S1OP] := false;
COLLAPSIBLE_OP [XABS_Q] := true;
COLLAPSIBLE_OP [XABS_H] := true;
COLLAPSIBLE_OP [XABS_S] := true;
COLLAPSIBLE_OP [XABS_D] := true;
COLLAPSIBLE_OP [XADD_S] := true;
COLLAPSIBLE_OP [XADD_D] := true;
COLLAPSIBLE_OP [XAND_Q] := true;
COLLAPSIBLE_OP [XAND_D] := true;
COLLAPSIBLE_OP [XAND_TC_D] := true;
COLLAPSIBLE_OP [XAND_CT_D] := true;
COLLAPSIBLE_OP [XDEC_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_D] := true;
COLLAPSIBLE_OP [XFLOAT_S_Q] := true;
COLLAPSIBLE_OP [XFLOAT_S_H] := true;
COLLAPSIBLE_OP [XFLOAT_S_S] := true;
COLLAPSIBLE_OP [XFLOAT_S_D] := true;
COLLAPSIBLE_OP [XFADD_S] := true;
COLLAPSIBLE_OP [XFADD_D] := true;
COLLAPSIBLE_OP [XFSUB_S] := true;
COLLAPSIBLE_OP [XFSUBV_S] := true;
COLLAPSIBLE_OP [XFSUB_D] := true;
COLLAPSIBLE_OP [XFSUBV_D] := true;
COLLAPSIBLE_OP [XFMULT_S] := true;
COLLAPSIBLE_OP [XFMULT_D] := true;
COLLAPSIBLE_OP [XFDIV_S] := true;
COLLAPSIBLE_OP [XFDIVV_S] := true;
COLLAPSIBLE_OP [XFDIV_D] := true;
COLLAPSIBLE_OP [XFDIVV_D] := true;
COLLAPSIBLE_OP [XFTRANS_S_D] := true;
COLLAPSIBLE_OP [XFTRANS_D_S] := true;
COLLAPSIBLE_OP [XINC_S] := true;
COLLAPSIBLE_OP [XMOV_A] := true;
COLLAPSIBLE_OP [XMOV_Q_Q] := true;
COLLAPSIBLE_OP [XMOV_Q_H] := true;
COLLAPSIBLE_OP [XMOV_H_Q] := true;
COLLAPSIBLE_OP [XMOV_H_H] := true;
COLLAPSIBLE_OP [XMOV_Q_S] := true;
COLLAPSIBLE_OP [XMOV_H_S] := true;
COLLAPSIBLE_OP [XMOV_S_Q] := true;
COLLAPSIBLE_OP [XMOV_S_H] := true;
COLLAPSIBLE_OP [XMOV_S_S] := true;
COLLAPSIBLE_OP [XMOV_Q_D] := true;
COLLAPSIBLE_OP [XMOV_H_D] := true;
COLLAPSIBLE_OP [XMOV_S_D] := true;
COLLAPSIBLE_OP [XMOV_D_Q] := true;
COLLAPSIBLE_OP [XMOV_D_H] := true;
COLLAPSIBLE_OP [XMOV_D_S] := true;
COLLAPSIBLE_OP [XMOV_D_D] := true;
COLLAPSIBLE_OP [XMULT_S] := true;
COLLAPSIBLE_OP [XMULT_D] := true;
COLLAPSIBLE_OP [XNEG_Q] := true;
COLLAPSIBLE_OP [XNEG_H] := true;
COLLAPSIBLE_OP [XNEG_S] := true;
COLLAPSIBLE_OP [XNEG_D] := true;
COLLAPSIBLE_OP [XOR_Q] := true;
COLLAPSIBLE_OP [XOR_D] := true;
COLLAPSIBLE_OP [XQUO_S] := true;
COLLAPSIBLE_OP [XQUOV_S] := true;
COLLAPSIBLE_OP [XQUO_D] := true;
COLLAPSIBLE_OP [XQUOV_D] := true;
COLLAPSIBLE_OP [XREM_S] := true;
COLLAPSIBLE_OP [XREMV_S] := true;
COLLAPSIBLE_OP [XREM_D] := true;
COLLAPSIBLE_OP [XREMV_D] := true;
COLLAPSIBLE_OP [XSHF_LF_D] := true;
COLLAPSIBLE_OP [XSHFV_LF_D] := true;
COLLAPSIBLE_OP [XSHFA_LF_S] := true;
COLLAPSIBLE_OP [XSHFAV_LF_S] := true;
COLLAPSIBLE_OP [XSUB_S] := true;
COLLAPSIBLE_OP [XSUBV_S] := true;
COLLAPSIBLE_OP [XSUB_D] := true;
COLLAPSIBLE_OP [XSUBV_D] := true;
COLLAPSIBLE_OP [XTRANS_Q_Q] := true;
COLLAPSIBLE_OP [XTRANS_Q_H] := true;
COLLAPSIBLE_OP [XTRANS_H_Q] := true;
COLLAPSIBLE_OP [XTRANS_H_H] := true;
COLLAPSIBLE_OP [XTRANS_Q_S] := true;
COLLAPSIBLE_OP [XTRANS_H_S] := true;
COLLAPSIBLE_OP [XTRANS_S_Q] := true;
COLLAPSIBLE_OP [XTRANS_S_H] := true;
COLLAPSIBLE_OP [XTRANS_S_S] := true;
COLLAPSIBLE_OP [XTRANS_Q_D] := true;
COLLAPSIBLE_OP [XTRANS_H_D] := true;
COLLAPSIBLE_OP [XTRANS_S_D] := true;
COLLAPSIBLE_OP [XTRANS_D_Q] := true;
COLLAPSIBLE_OP [XTRANS_D_H] := true;
COLLAPSIBLE_OP [XTRANS_D_S] := true;
COLLAPSIBLE_OP [XTRANS_D_D] := true;
COLLAPSIBLE_OP [XXOR_Q] := true;
for S1OP := FIRSTS1OP to LASTS1OP do
DEST_PRECISION [S1OP] := S1ILLEGAL;
DEST_PRECISION [XABS_Q] := S1Q;
DEST_PRECISION [XABS_H] := S1H;
DEST_PRECISION [XABS_S] := S1S;
DEST_PRECISION [XABS_D] := S1D;
DEST_PRECISION [XADD_S] := S1S;
DEST_PRECISION [XADD_D] := S1D;
DEST_PRECISION [XAND_Q] := S1Q;
DEST_PRECISION [XAND_D] := S1D;
DEST_PRECISION [XAND_TC_D] := S1D;
DEST_PRECISION [XAND_CT_D] := S1D;
DEST_PRECISION [XDEC_S] := S1S;
DEST_PRECISION [XFX_DM_S_S] := S1S;
DEST_PRECISION [XFX_DM_S_D] := S1S;
DEST_PRECISION [XFLOAT_S_Q] := S1S;
DEST_PRECISION [XFLOAT_S_H] := S1S;
DEST_PRECISION [XFLOAT_S_S] := S1S;
DEST_PRECISION [XFLOAT_S_D] := S1S;
DEST_PRECISION [XFADD_S] := S1S;
DEST_PRECISION [XFADD_D] := S1D;
DEST_PRECISION [XFSUB_S] := S1S;
DEST_PRECISION [XFSUBV_S] := S1S;
DEST_PRECISION [XFSUB_D] := S1D;
DEST_PRECISION [XFSUBV_D] := S1D;
DEST_PRECISION [XFMULT_S] := S1S;
DEST_PRECISION [XFMULT_D] := S1D;
DEST_PRECISION [XFDIV_S] := S1S;
DEST_PRECISION [XFDIVV_S] := S1S;
DEST_PRECISION [XFDIV_D] := S1D;
DEST_PRECISION [XFDIVV_D] := S1D;
DEST_PRECISION [XFTRANS_S_D] := S1S;
DEST_PRECISION [XFTRANS_D_S] := S1D;
DEST_PRECISION [XINC_S] := S1S;
DEST_PRECISION [XMOV_A] := S1S;
DEST_PRECISION [XMOV_Q_Q] := S1Q;
DEST_PRECISION [XMOV_Q_H] := S1Q;
DEST_PRECISION [XMOV_H_Q] := S1H;
DEST_PRECISION [XMOV_H_H] := S1H;
DEST_PRECISION [XMOV_Q_S] := S1Q;
DEST_PRECISION [XMOV_H_S] := S1H;
DEST_PRECISION [XMOV_S_Q] := S1S;
DEST_PRECISION [XMOV_S_H] := S1S;
DEST_PRECISION [XMOV_S_S] := S1S;
DEST_PRECISION [XMOV_Q_D] := S1Q;
DEST_PRECISION [XMOV_H_D] := S1H;
DEST_PRECISION [XMOV_S_D] := S1S;
DEST_PRECISION [XMOV_D_Q] := S1D;
DEST_PRECISION [XMOV_D_H] := S1D;
DEST_PRECISION [XMOV_D_S] := S1D;
DEST_PRECISION [XMOV_D_D] := S1D;
DEST_PRECISION [XMULT_S] := S1S;
DEST_PRECISION [XMULT_D] := S1D;
DEST_PRECISION [XDIV_S] := S1S; (* als/peg 18jul79 *)
DEST_PRECISION [XNEG_Q] := S1Q;
DEST_PRECISION [XNEG_H] := S1H;
DEST_PRECISION [XNEG_S] := S1S;
DEST_PRECISION [XNEG_D] := S1D;
DEST_PRECISION [XOR_Q] := S1Q;
DEST_PRECISION [XOR_D] := S1D;
DEST_PRECISION [XQUO_S] := S1S;
DEST_PRECISION [XQUOV_S] := S1S;
DEST_PRECISION [XQUO_D] := S1D;
DEST_PRECISION [XQUOV_D] := S1D;
DEST_PRECISION [XREM_S] := S1S;
DEST_PRECISION [XREMV_S] := S1S;
DEST_PRECISION [XREM_D] := S1D;
DEST_PRECISION [XREMV_D] := S1D;
DEST_PRECISION [XSHF_LF_D] := S1D;
DEST_PRECISION [XSHFV_LF_D] := S1D;
DEST_PRECISION [XSHFA_LF_S] := S1S;
DEST_PRECISION [XSHFAV_LF_S] := S1S;
DEST_PRECISION [XSUB_S] := S1S;
DEST_PRECISION [XSUBV_S] := S1S;
DEST_PRECISION [XSUB_D] := S1D;
DEST_PRECISION [XSUBV_D] := S1D;
DEST_PRECISION [XTRANS_Q_Q] := S1Q;
DEST_PRECISION [XTRANS_Q_H] := S1Q;
DEST_PRECISION [XTRANS_H_Q] := S1H;
DEST_PRECISION [XTRANS_H_H] := S1H;
DEST_PRECISION [XTRANS_Q_S] := S1Q;
DEST_PRECISION [XTRANS_H_S] := S1H;
DEST_PRECISION [XTRANS_S_Q] := S1S;
DEST_PRECISION [XTRANS_S_H] := S1S;
DEST_PRECISION [XTRANS_S_S] := S1S;
DEST_PRECISION [XTRANS_Q_D] := S1Q;
DEST_PRECISION [XTRANS_H_D] := S1H;
DEST_PRECISION [XTRANS_S_D] := S1S;
DEST_PRECISION [XTRANS_D_Q] := S1D;
DEST_PRECISION [XTRANS_D_H] := S1D;
DEST_PRECISION [XTRANS_D_S] := S1D;
DEST_PRECISION [XTRANS_D_D] := S1D;
DEST_PRECISION [XXOR_Q] := S1Q;
end (*INIT7*);
(** INITIALIZE_CLASS: **)
(**)
begin (*INITIALIZE*)
INIT1;
INIT2;
INIT3;
INIT4;
INIT5;
INIT6;
INIT7; (*PBK*)
end (*INITIALIZE*);
(** MAIN_PROGRAM: **)
(**)
begin (*Main Program.*)
ASSERTCOUNT := 0;
INITIALIZE;
TIMER := CLOCK; (*X10S1*)
(*TIMER := CLOCK(1); *) (*X10S1*)
repeat
OLDINSTREC := NEWINSTREC;
OLDTOP := TOP;
OLDMSTTOP := MSTTOP;
READNXTINST;
if TR_UCODE then PRINTNXTINST;
ASMNXTINST;
if TR_S1CODE and (OLDINSTREC <> NEWINSTREC) then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then
OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := NEXT_INSTRUCTION(OLDINSTREC);
end;
end;
if TR_STACK then
begin
if OLDTOP < TOP then
WRITELN (OUTPUT, ' Stack pushed. New top is ',
TOP : FLDW(TOP) )
else if OLDTOP > TOP then
WRITELN (OUTPUT, ' Stack popped. New top is ',
TOP : FLDW(TOP) )
else if TOP >= BOT then
WRITELN (OUTPUT, ' Stack top is ')
else
WRITELN (OUTPUT, ' Stack is empty.');
if TOP >= BOT then PRINTDATUM (TOP);
end;
if TR_MST and (MSTTOP <> OLDMSTTOP) then
begin
if OLDMSTTOP < MSTTOP then
WRITELN (OUTPUT, ' MST stack pushed. New top is ',
MSTTOP : FLDW(MSTTOP) )
else if OLDMSTTOP > MSTTOP then
WRITELN (OUTPUT, ' MST stack popped. New top is ',
MSTTOP : FLDW(MSTTOP) );
PRINT_MSTENTRY (MSTTOP);
end;
until OPC = USTP;
WRITELN (OUTPUT,'************************** ;START OF STATISTICS'); (*LCW*)
WRITELN (OUTPUT,'************************** ;WRITER-ID: ',
SOPA_ID); (*23JUL79 PTZ*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' PEEPHOLE OPTIMIZER STATISTICS:'); (*PBK*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' ',J_TO_J_CNT:7,' JMPAS CHAINED'); (*PBK*)
WRITELN (OUTPUT,' ',JMPAS_REMOVED_FROM_SKIPS:7,' JMPAS REMOVED FROM SKIPS');(*PTZ*)
WRITELN (OUTPUT,' ',MOVS_COLLAPSED:7,' MOVS COLLAPSED'); (*PTZ*)
WRITELN (OUTPUT); (*PTZ*)
WRITELN (OUTPUT,' ',INSTR_WDS_REMOVED:7,' TOTAL WORDS REMOVED'); (*PTZ*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' INSTRUCTION COUNTS:'); (*LCW*)
WRITELN (OUTPUT); (*LCW*)
S1OP_TOT := 0; (*LCW*)
for S1OP := FIRSTS1OP to LASTS1OP do (*LCW*)
if OPFORMAT[S1OP] <> VFAKEOP then (*LCW*)
begin (*LCW*)
S1OP_TOT := S1OP_TOT + S1OP_CNT[S1OP]; (*LCW*)
if S1OP_CNT[S1OP] <> 0 (*LCW*)
then WRITELN (OUTPUT,' ',S1OP_CNT[S1OP]:7,' ',S1MNEM[S1OP]); (*LCW*)
end; (*LCW*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',S1OP_TOT:7,' TOTAL INSTRUCTIONS'); (*LCW*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',WORD_CNT:7,' TXT WORDS OUTPUT TO LOADER FILE'); (*LCW*)
TIMER := ( CLOCK - TIMER ) div 10; (*X10S1*)
(*TIMER := ( CLOCK(1) - TIMER ) div 10; *) (*X10S1*)
WRITELN(OUTPUT);
WRITE (OUTPUT, ' ****' : 14);
if ERRORCNT > 0 then WRITE (OUTPUT, ERRORCNT : 5)
else WRITE (OUTPUT, 'NO' : 5);
WRITELN (OUTPUT, ' ASSEMBLY ERROR(S) DETECTED,',
TIMER div 100 : 3, '.', TIMER mod 100 : 2,
' SECONDS in P-CODE ASSEMBLY.' );
if ERRORCNT <> 0 then ERREXIT (ERRORCNT);
end. (*Main Program*)